Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 223 След.
Составление шаблона под определенную маску регулярными выражениями
 
Цитата
под шаблон Крайнова С.В.
под шаблон Крайнова С.
Код
.Pattern = "[А-ЯЁ][а-яё]+ [А-ЯЁ]\.([А-ЯЁ]\.)?"
Вытащить часть текста из таблицы
 
UDF
Код
Function iDevice(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "Device: (.+)(?=: S)"
     iDevice = .Execute(cell)(0).Submatches(0)
 End With
End Function
Разбиение (разделение) данных по отделам на несколько листов
 
Код
Swod.Range(Swod.Cells(FoundNomer.Row, "A"), Swod.Cells(FoundNomer.Row, "K")).Copy Cells(iLR,"A")
Разбиение (разделение) данных по отделам на несколько листов
 
В макросе нашли FoundNomer
Строка  от A до К будет Swod.Range(Swod.Cells(FoundNomer.Row, "A"), Swod.Cells(FoundNomer.Row, "K"))
Вот этот диапазон и копируйте
Разбиение (разделение) данных по отделам на несколько листов
 
Цитата
нужно всю строку копировать
Всю строку с листа "свод"?
Разбиение (разделение) данных по отделам на несколько листов
 
Макрос в стандартный модуль, запускать при активном листе "кто"
Листы по отделам создаются в процессе работы макроса
Код
'при активном листе кто
Sub Razbienie()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundNomer As Range
Dim j As Integer
Dim Swod As Worksheet
Dim Kto As Worksheet
  Set Swod = ThisWorkbook.Worksheets("свод")
  Set Kto = ThisWorkbook.Worksheets("кто")
  For j = 1 To 8     'цикл по строке с отделами
   iLastRow = Cells(Rows.Count, j).End(xlUp).Row
     'создаем новый лист
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    With Worksheets(Worksheets.Count)
      .Name = Kto.Cells(1, j)  'название листа с именем отдела
      For i = 2 To iLastRow - 1  'цикл по строкам
        Set FoundNomer = Swod.Columns(2).Find(Kto.Cells(i, j), , xlValues, xlWhole)
        If Not FoundNomer Is Nothing Then
          iLR = Cells(Rows.Count, 1).End(xlUp).Row + 1
          Cells(iLR, 1) = FoundNomer.Offset(, -1)  'дата
          Cells(iLR, 1).NumberFormat = "dd.mm.yyyy"
          Cells(iLR, 2) = FoundNomer               'номер
        End If
      Next
    End With
    Kto.Activate
  Next
End Sub
Разбиение (разделение) данных по отделам на несколько листов
 
Цитата
на 8 листов с соответствующим названием отдела.
Вы бы привели пример одного листа, что на нем должно быть
Убрать отступы между строк в одной ячейке сохраняя их последовательность.
 
Код
Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim arr
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("B1:B" & iLastRow).ClearContents
  For i = 1 To iLastRow
    arr = Split(Cells(i, "A"), Chr(10))
    For j = 0 To UBound(arr)
      If arr(j) <> " " Then
        Cells(i, "B") = Cells(i, "B") & arr(j) & Chr(10)
      End If
    Next
  Next
End Sub
Разбиение (разделение) данных по отделам на несколько листов
 
FrinG, написал
Цитата
Очень прошу помочь в написании макроса.
А где ваши попытки? Или все нужно сделать с нуля за вас?
Макрос найти данные в определенной книги из активной книги, и перенести в определенную книгу
 
Обе книги должны быть открыты
Номера телефонов привести к единому формату
 
UDF формат +7(000)000-00-00
Код
Public Function RgxPhone(iString As Range) As String
 Dim re As Object
 Dim tempString
  Set re = CreateObject("vbscript.regexp")
    re.Pattern = "(-|\s|\+|\(|\))"
    re.Global = True
    re.IgnoreCase = True
 tempString = re.Replace(iString, "")
 re.Pattern = "((8)|(7))(\d{3})+(\d{3})+(\d{2})+(\d{2})+"
  If re.Test(tempString) Then
   RgxPhone = re.Replace(tempString, "$1$2($4) $5-$6-$7")
    If (Left(RgxPhone, 1) <> "8") Then
        RgxPhone = "+" + RgxPhone
    Else
       RgxPhone = "+7" + Mid(RgxPhone, 3)
    End If
  End If
End Function
Последние слова в ячейке оставить, От многословной фразы оставить формулой только последние три-четыре слова я ячейке
 
UDF  вызывается =WordsEnd(A1;" ";4)
Код
Function WordsEnd(cell As String, delimiter As String, n As Integer) As String
  Dim arr
  Dim i As Integer
  If Len(cell) - Len(Replace(cell, delimiter, "")) >= n Then
    arr = Split(cell, delimiter)
      For i = UBound(arr) - n + 1 To UBound(arr)
        WordsEnd = WordsEnd & arr(i) & delimiter
      Next
  Else
    WordsEnd = cell
  End If
End Function
Изменено: Kuzmich - 15 Янв 2020 20:31:51
Ошибка с макросом при изменении данных на листе, Ошибка Out of stack space при выполнении макроса с завязкой на изменение на листе
 
Макрос должен быть в модуле Лист1
Код
Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("B1:B2")) Is Nothing Then
   Application.Calculation = xlCalculationManual
   Application.EnableEvents = False
Dim m_pr, s_pr, d_pr, eq_f, eq_s As Single
  m_pr = Range("B1")
  s_pr = Range("B2")
  d_pr = 0
  Do Until eq_f < eq_s
    d_pr = d_pr + 0.01
    eq_f = m_pr / d_pr
    eq_s = 1.3 * d_pr / s_pr
    If eq_f < eq_s Then Exit Do
  Loop
     Range("B3") = d_pr
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
  End If
End Sub

При таком объявлении переменных, как у вас
Код
Dim m_pr, s_pr, d_pr, eq_f, eq_s As Single

Только eq_s As Single, остальные будут Variant
Удалиение строк. Оставить значения первого столбца с максимальным значением из второго столбца
 
Код
Sub DelRow()
Dim i As Long
Dim iLastRow As Long
Dim iMax As Double
Dim n As Long
Dim k As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = iLastRow To 3 Step -1
    iMax = Cells(i, "B")
      n = i
    Do
     If Cells(n - 1, "A") = Cells(n, "A") Then
      If Cells(n - 1, "B") > Cells(n, "B") Then iMax = Cells(n - 1, "B")
      n = n - 1
     End If
    Loop While Cells(n - 1, "A") = Cells(n, "A")
    For k = i To n Step -1
      If Cells(k, "B") <> iMax Then Rows(k).Delete
    Next
      i = n
  Next
End Sub
Формирование таблицы уникальных товаров с более поздним номером прихода из базы данных
 
Тема: Формирование таблицы уникальных товаров с более поздним номером прихода из базы данных
Формирование таблицы уникальных товаров с более поздним номером прихода из базы данных
 
Код
Sub UnicTowar()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundTowar As Range
 iLastRow = Range("B4").End(xlDown).Row
 Range("G5:J" & iLastRow).Clear
 Range("C4:C" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("H4"), Unique:=True
 Range("B4:E4").Copy Range("G4")
 iLR = Cells(Rows.Count, "H").End(xlUp).Row
   For i = 5 To iLR
     Set FoundTowar = Range("C4:C" & iLastRow).Find(Cells(i, "H"), , xlValues, xlWhole, , xlPrevious)
     Cells(i, "J") = Cells(FoundTowar.Row, "E")
     Cells(i, "G") = Cells(FoundTowar.Row, "B")
   Next
   Range("G4:J" & iLR).Borders.Weight = xlThin
End Sub
[ Закрыто] Работа с таблицой, Объединение повторяющихся строк, сложение данных
 
Как артикул 0011 в примере превратился в 0012 ?
Последовательное копирование и вставка. Макрос
 
Nazar93, написал
Цитата
Нужен макрос, который  сможет выполнить следующие действия:
А почему сразу не заполнять ячейки B11:B20 рандомными значениями?
Список по 4-м критериям из массива в одной книге, Список по 4-м критериям из массива в одной книге на разных листах
 
Макрос в модуль листа Заявка, срабатывает при изменении ячеек C8:C11
В этих ячейках желательно сделать выпадающие списки
Код
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("C8:C11")) Is Nothing Then
    Application.EnableEvents = False
Dim FoundCell As Range
Dim FAdr As String
Dim FoundMonthCol As Integer
Dim iLastRow As Integer
  With Worksheets("Data")
   iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
   If iLastRow > 14 Then Range("C14:D" & iLastRow).ClearContents
    Set FoundCell = .Columns(1).Find(Range("C8"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then                                   'нашли ФИО
      FAdr = FoundCell.Address
      Do
        If FoundCell.Offset(, 1) = Range("C9") And FoundCell.Offset(, 2) = Range("C10") Then
          FoundMonthCol = .Rows(1).Find(Range("C11"), , xlValues, xlWhole).Column
          iLastRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
          Cells(iLastRow, "C") = FoundCell.Offset(, 3)                  'наименование
          Cells(iLastRow, "D") = .Cells(FoundCell.Row, FoundMonthCol)   'количество
        End If
         Set FoundCell = .Columns(1).Find(Range("C8"), After:=FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
  End With
 End If
  Application.EnableEvents = True
End Sub
Изменено: Kuzmich - 14 Янв 2020 14:07:25
Поиск в таблице 1 слова и подстановка из таблицы 2 значения
 
Сложность может быть при замене, когда искомое слово входит в состав другого.
Например 'ред' входит в 'редкий' , и как тогда заменять?
Содержимое ячейки разбить по столбцам
 
Сначала надо отписаться в своих предыдущих темах, а уж потом создавать новые.
Сложение элементов массива по условию
 
Цитата
все суммы одинаковых по жильности кабелей
Результат в столбцах А и В
Код
Sub iArr()
Dim i As Integer
Dim dicObj As Object
Dim Arr
ReDim Arr(0 To 3) As String
Arr(0) = "500-1x2"
Arr(1) = "100-1x2"
Arr(2) = "200-7x2"
Arr(3) = "300-7x2"
  Set dicObj = CreateObject("scripting.dictionary")
    For i = LBound(Arr) To UBound(Arr)
      dicObj.Item(Split(Arr(i), "-")(1)) = dicObj.Item(Split(Arr(i), "-")(1)) + CDbl(Split(Arr(i), "-")(0))
    Next
     Range("A1").Resize(dicObj.Count, 2) = Application.Transpose(Array(dicObj.keys, dicObj.Items))
End Sub
Суммирование помесячно.
 
Цитата
Все пробовала, ТУПИК.
Пробуйте
Код
Sub Oborudovanie()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim FoundCell As Range
Dim FAdr As String
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("B3:M" & iLastRow).ClearContents
  For i = 3 To iLastRow
    For j = 2 To 13
    Set FoundCell = Columns(17).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
        FAdr = FoundCell.Address
      Do
        If Month(Cells(FoundCell.Row, "O")) = Month(Cells(2, j)) Then
         Cells(i, j) = Cells(i, j) + 1
        End If
         Set FoundCell = Columns(17).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
    Next
  Next
End Sub
Сортировка данных таблицы по листам по признаку в определенном столбце
 
Цитата
Форматирование в добавленных строках слетает (буду допиливать).
Добавьте в макрос строку
Код
Range(Cells(iLR_old - 2, "J"), Cells(iLR_old - 2, iLastCol)).Copy
Range(Cells(iLR_old - 1, "J"), Cells(iLR, iLastCol)).PasteSpecial xlPasteFormulas
Range(Cells(iLR_old - 1, "J"), Cells(iLR, iLastCol)).PasteSpecial xlPasteFormats

Удачи!
Как из ячеек с текстом и числами суммировать только числа?
 
Цитата
Может можно прописать сумму этих чисел в ячейке независимо от количества.  
12б, 5гк, 11р
Код
Public Function RegExpExtract(Text As String, Pattern As String, Optional Item As Integer = 1) As Double
    On Error GoTo ErrHandl
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = Pattern
    regex.Global = True
    If regex.Test(Text) Then
        Set matches = regex.Execute(Text)
        For n = 0 To matches.Count - 1
          RegExpExtract = RegExpExtract + CDbl(matches(n))
        Next
        Exit Function
    End If
ErrHandl:
    RegExpExtract = CVErr(xlErrValue)
End Function
Как найти дату по позиции в накладной позднее определенной даты
 
Цитата
некоторые даты бьются некорректно
Видимо нужно искать по номеру вагона(они у вас повторяются) и по дате
Сортировка данных таблицы по листам по признаку в определенном столбце
 
Цитата
Я макросами к сожалению не владею напрочь.
Не представляю, как можно использовать макросы в работе, не владея ими?
Вот попробуйте следующий вариант. Пилите Шура (masaran), пилите... Удачи!
Скрытый текст
Замена первого пробела в ячейке
 
И в прошлых темах отписываться
Сортировка данных таблицы по листам по признаку в определенном столбце
 
masaran,
При переносе данных с нового листа Общ может возникнуть два момента
1. Число переносимых строк больше чем было при предыдущем переносе  убираем старую заливку строк Итого и Сальдо от столбца J и правее  копируем формулы в добавленные строки
2. Число переносимых строк меньше чем было при предыдущем переносе удаляем лишние строки
3. Надо все это зациклить на все листы по группам

Вы сами пробовали что-то сделать из этого?
Заполнение пропущенных дат с интервалом в сутки
 
webulus, написал
Цитата
Подскажите пожалуйста, как исправить.
У вас в книге нет листа Результат, видимо вы не прочитали мое сообщение #8.
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 223 След.
Наверх