Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 264 След.
Как вытащить из строки подстроку по маске расположенной в случайном порядке?
 
Цитата
возможно получить такой результат
Используйте
Код
Function iFio(iCell As Range) As String
Dim re
Set re = CreateObject("VBScript.RegExp")
     re.Global = True
'     re.MultiLine = True
re.Pattern = "\|([А-ЯЁ][а-яё]+ [А-ЯЁ]\.[А-ЯЁ]\.?)\|"
    iFio = re.Execute(iCell)(0).SubMatches(0)
End Function
Как вытащить из строки подстроку по маске расположенной в случайном порядке?
 
Цитата
подскажите, как в маску добавить знак "|" ?
Вы в файле покажите варианты написания ФИО в ячейке и какой результат вы желаете получить
Цитата
Если я корректирую код добавляя "|" так
Надо вставлять \|
Изменено: Kuzmich - 25.06.2022 23:11:11
Как вытащить из строки подстроку по маске расположенной в случайном порядке?
 
UDF
Код
Function iFio(iCell As Range) As String
Dim re
Set re = CreateObject("VBScript.RegExp")
     re.Global = True
re.Pattern = "[А-ЯЁ][а-яё]+ [А-ЯЁ]\.([А-ЯЁ]\.)?"
    iFio = re.Execute(iCell)(0)
End Function
Разделить данные Листа на несколько отдельных листов
 
В исходный файл с одним листом Лист1 вставьте в стандартный модуль код.
Код
Sub Tablica()
Dim NewSheet As Worksheet
Dim iLR As Long
Dim iRow_Begin As Long
Dim iNomer As String
Dim FoundNomerSwerki As Range
Dim FAdr As String
Application.ScreenUpdating = False
    Set FoundNomerSwerki = Columns("C:D").Find("Номер сверки заказа:", , xlValues, xlWhole)
      FAdr = FoundNomerSwerki.Address
    Do
      iRow_Begin = FoundNomerSwerki.Row                     'начало очередного диапазона по номеру сверки
      iNomer = FoundNomerSwerki.Offset(, 1)                 'номер сверки
      iLR = FoundNomerSwerki.Offset(5).End(xlDown).Row      'конец  очередного диапазона
      
      'здесь копируем диапазон от iRow_Begin до iLR и вставляем в лист с именем iNomer
      'если такого листа нет, то добавляем лист
        If Not SheetExist(iNomer) Then                      'функция проверки наличия листа в файле
          Set NewSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
          NewSheet.Name = iNomer
          With Worksheets("Лист1")
            .Range(.Cells(iRow_Begin, "C"), .Cells(iLR, "Z")).Copy Range("A1")
            .Activate
          End With
        End If
      Set FoundNomerSwerki = Columns("C:D").FindNext(FoundNomerSwerki)
    Loop While FoundNomerSwerki.Address <> FAdr
Application.ScreenUpdating = True
End Sub

Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function


При активном листе Лист1 запустите макрос Tablica()
Разделить данные Листа на несколько отдельных листов
 
Цитата
Пример того, что должно получаться прикладываю
Я так понимаю, что у вас есть файл с одним листом Лист1 и надо сформировать n-ое количество листов под именами номера заказа.
Имена заказов у вас уникальные?
Смущает, что вы
Цитата
В макросах ни бум-бум
как будете разбираться?
Как из строки удалить числа с их единицами измерения, в строчках есть ватность а где то нет, нужно убрать и чтобы структура осталась не изменой
 
ТС писал
Цитата
надо не только вт убрать, а убрать например "(857Вт)
тогда
Код
re.Pattern = " \(\d+ ?Вт\)"
Частичный вывод из TextBox в MsgBox
 
По мотивам кода New
Код
Private Sub CommandButton1_Click()
Dim arr As Variant
    'Me.TextBox1.Text = "Иванов Иван Иванович"
    arr = Split(Me.TextBox1.Text, " ",2)
    MsgBox arr(1) , 64, "Сообщение"
End Sub
из текста разделенного на произвольное количество частей получить фрагмент из последней части
 
UDF
Код
Function iPart(cell$)
Dim mo As Object
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[^\\]+"
   If .test(cell) Then
     Set mo = .Execute(cell)
     iPart = mo(mo.Count - 1)
     .Pattern = "\[.+\]"
     iPart = .Replace(iPart, "")
   Else
     iPart = ""
   End If
 End With
End Function
Найти неповторяющиеся нормы у повторяющихся заказов
 
Цитата
чтоб одинаковые нормы не отображались
Код
Sub iZadacha()
Dim i As Long
Dim iLastRow As Long
Dim iFoundZadacha As Range
Dim FAdr As String
Dim Norma As Range
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("K1:L" & iLastRow).Clear
   Range("A2:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("K1"), Unique:=True
   For i = 2 To Cells(Rows.Count, "K").End(xlUp).Row
     If Application.WorksheetFunction.CountIf(Range("A2:A" & iLastRow), Cells(i, "K")) > 1 Then
        Set iFoundZadacha = Columns(1).Find(Cells(i, "K"), , xlFormulas, xlWhole)
          FAdr = iFoundZadacha.Address
          Set Norma = iFoundZadacha.Offset(, 1)
          Cells(i, "L") = iFoundZadacha.Row & ", "
        Do
          If iFoundZadacha.Offset(, 1) <> Norma Then
            Cells(i, "L") = Cells(i, "L") & iFoundZadacha.Row & ", "
          End If
          Set iFoundZadacha = Columns(1).FindNext(iFoundZadacha)
        Loop While iFoundZadacha.Address <> FAdr
     End If
   Next
End Sub
Найти неповторяющиеся нормы у повторяющихся заказов
 
Код
Sub iZadacha()
Dim i As Long
Dim iLastRow As Long
Dim iFoundZadacha As Range
Dim FAdr As String
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("K1:L" & iLastRow).Clear
   Range("A2:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("K1"), Unique:=True
   For i = 2 To Cells(Rows.Count, "K").End(xlUp).Row
     If Application.WorksheetFunction.CountIf(Range("A2:A" & iLastRow), Cells(i, "K")) > 1 Then
        Set iFoundZadacha = Columns(1).Find(Cells(i, "K"), , xlFormulas, xlWhole)
          FAdr = iFoundZadacha.Address
        Do
          Cells(i, "L") = Cells(i, "L") & iFoundZadacha.Row & ", "
          Set iFoundZadacha = Columns(1).FindNext(iFoundZadacha)
        Loop While iFoundZadacha.Address <> FAdr
     End If
   Next
End Sub

Макрос выводит в столбец К уникальные задачи, а в столбец L строки, где эти задачи совпадают.
Какие нормы правильные вам решать.
Вывод в msgbox текст из ячяек
 
Только надо
Код
adrs = adrs & vbLf & c.Address(0, 0) & ":  " & c.Offset(0, -3)
Найти неповторяющиеся нормы у повторяющихся заказов
 
Код
двух столбцах значение которых, нужно сравнить и найти ошибку

Что вы подразумеваете под ошибкой? Поясните на примере задачи 1
Как посчитать сумму чисел находящихся одной ячейке, стоимость нескольких услуг прописывается в одну ячейку, нужно посчитать ее сумму
 
Код
как посчитать сумму этой ячейки

Код
Sub GetSumma()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .MultiLine = True
  .Pattern = "^\d+$"
  For i = 3 To iLastRow
    If .Test(Cells(i, 2)) Then
      Set mo = .Execute(Cells(i, 2))
      For n = 0 To mo.Count - 1
        Cells(i, 3) = Cells(i, 3) + CDbl(mo(n))
      Next
    End If
  Next
End With
End Sub
Определение диапазона объединенной ячейки.
 
Код
    If Cells(KolStrok, 1).MergeCells Then
      iAdr = Cells(KolStrok, 1).MergeArea.Address(False, False)
    End If
Определение диапазона объединенной ячейки.
 
Число строк на странице
Код
Dim KolStrok As Long
    KolStrok = ActiveSheet.HPageBreaks(1).Location.Row - 1

Проверяйте объединенная ли ячейка на границе листа и сдвигайте горизонтальный разрыв
размножить листы и заполнить по условию, ведомость по списку на каждого сотрудника
 
Цитата
создать ведомость на каждого сотрудника
При активном листе список водителей запустить макрос в стандартном модуле
Код
Sub iCreateListFIO()
Dim FIO As String
Dim i As Long
Dim Shablon As Worksheet
Dim TabNomer As Long

  Set Shablon = ThisWorkbook.Worksheets("1")
  For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
    FIO = Split(Cells(i, "B"), " ")(0) & " " & Left(Split(Cells(i, "B"), " ")(1), 1) _
          & "." & Left(Split(Cells(i, "B"), " ")(2), 1) & "."
    TabNomer = Cells(i, "C")
    If Not SheetExist(FIO) Then Shablon.Copy After:=Worksheets(Sheets.Count)
    ActiveSheet.Name = FIO
      Range("B16:B22") = FIO
      Range("H16:H22") = TabNomer
    Worksheets("список водителей").Activate
  Next
End Sub

     'функция проверки наличия листа в файле, лист есть - true
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function
Извлечь из текста цифры, расположенные между определенными символами
 
UDF в стандартный модуль
Код
Function iDigits(cell$)
 With CreateObject("VBScript.RegExp")
     .Pattern = "\d+(?=/)"
   If .test(cell) Then
     iDigits = .Execute(cell)(0)
   Else
     iDigits = ""
   End If
 End With
End Function
Найти номер столбца с последней заполненной ячейкой в строке
 
Код
Sub iLastColumn()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("M2:M" & iLastRow).ClearContents
    For i = 2 To iLastRow
      For j = 10 To 5 Step -1
        If Cells(i, j) <> "" Then
          Cells(i, 13) = Cells(i, j).Column
          Exit For
        End If
      Next
    Next
End Sub
как можно очистить столбец, кроме заголовка?, перед заполнением
 
Цитата
а потом всё смещается вниз
Перед циклом добавьте j=2
Код
j = S2.Cells(Columns(1).Cells.Count, ListCol).End(xlUp).Row + 1
  S2.Range("D2:D" & j).ClearContents
j=2
как можно очистить столбец, кроме заголовка?, перед заполнением
 
Цитата
Как можно очистить столбец, сохраняя заголовок,
Добавить в макрос строку перед циклом
Код
j = S2.Cells(Columns(1).Cells.Count, ListCol).End(xlUp).Row + 1
  S2.Range("D2:D" & j).ClearContents
Пытаюсь настроить перенос строк из общего списка при наличии аргументов и с учетом свободных строк
 
Код
Sub Sotrudnik()
Dim i As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("H3:J" & iLastRow).ClearContents
  For i = 3 To iLastRow
    If Cells(i, "B") = "цех" Then
      Cells(Cells(Rows.Count, "H").End(xlUp).Row + 1, "H") = Cells(i, "A")
    ElseIf Cells(i, "B") = "склад" Then
      Cells(Cells(Rows.Count, "I").End(xlUp).Row + 1, "I") = Cells(i, "A")
    Else
      Cells(Cells(Rows.Count, "J").End(xlUp).Row + 1, "J") = Cells(i, "A")
    End If
  Next
End Sub
Посчитать количество заполненных ячеек между ячейками с заданными словами
 
Код
Sub ПосчитатьЯчейки()
Dim arr
Dim S As String
Dim i As Integer
Dim cell_1 As Range
Dim cell_2 As Range
  arr = Array("Шкафы-купе", "Шкафы", "Комоды", "Прихожие", "Конец таблицы")
  For i = 0 To UBound(arr) - 1
    Set cell_1 = Columns(2).Find(arr(i), , xlValues, xlWhole)
    Set cell_2 = Columns(2).Find(arr(i + 1), , xlValues, xlWhole)
    S = S & arr(i) & ":" & WorksheetFunction.CountA(Range("B" & cell_1.Row + 1 & ":B" & cell_2.Row - 1)) & vbCrLf
  Next
  MsgBox S
End Sub
Как посчитать сумму, когда в ячейках цифры и текст написаны вместе?
 
Код
Sub GetSumma()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .MultiLine = True
  .Pattern = "\d+(,\d+)?$"
  For i = 1 To iLastRow
      Cells(i, 3) = 0
    If .Test(Cells(i, 1)) Then
      Set mo = .Execute(Cells(i, 1))
      For n = 0 To mo.Count - 1
        Cells(i, 3) = Cells(i, 3) + CDbl(mo(n))
      Next
    End If
  Next
End With
End Sub

Результат в столбце С
Нужно чтобы консолидация суммировала только один столбец из нескольких
 
Цитата
просуммировала только кол-во
Код
Sub Marka()
Dim arr
Dim dic As Object
Dim i As Long
Dim iLastRow As Long
Dim iKey
    iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
     Range("H4:K" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     arr = Range("C4:F" & iLastRow).Value
  For i = 1 To UBound(arr)
    dic.Item(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) = _
    dic.Item(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) + arr(i, 4)
  Next i
    i = 4
  For Each iKey In dic.keys
    Cells(i, "H") = Split(iKey, "|")(0)
    Cells(i, "I") = Split(iKey, "|")(1)
    Cells(i, "J") = Split(iKey, "|")(2)
    Cells(i, "K") = dic.Item(iKey)
    i = i + 1
  Next
End Sub
Как посчитать в табеле часы, когда в ячейках цифры и символы написаны вместе?
 
Код
Sub iSumma()
Dim j As Long
Dim iSumma As Double
  For j = 3 To 33 'от C до AG
    If IsNumeric(Cells(7, j)) Then
      iSumma = iSumma + Cells(7, j)
    Else
      If InStr(1, Cells(7, j), "/") > 0 Then
        iSumma = iSumma + Split(Cells(7, j), "/")(0)
          If IsNumeric(Split(Cells(7, j), "/")(1)) Then
            iSumma = iSumma + Split(Cells(7, j), "/")(1)
          End If
      End If
    End If
  Next
    Cells(7, "AH") = iSumma
End Sub
Как посчитать в табеле часы, когда в ячейках цифры и символы написаны вместе?
 
Цитата
суммировать с остальными.
у меня получилась сумма 179,5. правильно?
Перенос вертикально горизонтально расположенных данных (с различным числом строк)
 
MVMM, а зачем
Цитата
вручную можно было  определить область выгрузки
Добавьте в книгу Лист1
Код
Sub iChicken_1()
Dim i As Long
Dim j As Long
Dim n As Long
Dim iLR As Long
Dim iLastRow As Long
 With Worksheets("Лист1")
   .Cells.Clear
   iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   iLR = Range("B1").End(xlDown).Row
   For i = 2 To iLR
     If Cells(i, "C") = "Курицы" Then
       n = 21
     Else
       n = 31
     End If
       For j = 6 To n Step 2
         .Cells(iLastRow, "A") = Cells(i, "A")
         .Cells(iLastRow, "B") = Cells(i, "C")
         .Cells(iLastRow, "C") = Cells(i, j)
         .Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
   Next
   .Range("A2:D" & iLastRow - 1).Borders.Weight = xlThin
   .Activate
 End With
End Sub
Изменено: Kuzmich - 12.01.2022 11:13:03
Перенос вертикально горизонтально расположенных данных (с различным числом строк)
 
Код
Sub iChicken()
Dim i As Long
Dim j As Long
Dim iLR As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
 iLR = Range("B1").End(xlDown).Row
   Range("A15:D" & iLastRow).ClearContents
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
   For i = 2 To iLR
     If Cells(i, "C") = "Курицы" Then
       For j = 6 To 21 Step 2
         Cells(iLastRow, "A") = Cells(i, "A")
         Cells(iLastRow, "B") = Cells(i, "C")
         Cells(iLastRow, "C") = Cells(i, j)
         Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
     Else
       For j = 6 To 31 Step 2
         Cells(iLastRow, "A") = Cells(i, "A")
         Cells(iLastRow, "B") = Cells(i, "C")
         Cells(iLastRow, "C") = Cells(i, j)
         Cells(iLastRow, "D") = Cells(i, j + 1)
         iLastRow = iLastRow + 1
       Next
     End If
   Next
End Sub
Макрос сравнения двух списков на разных листах в одной книге
 
Вы сообщение 3 смотрели?
Где в вашем примере макрос?
Макрос сравнения двух списков на разных листах в одной книге
 
Код
Set Found = ws1.Range("B2:B" & ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row).Find(Numbers2(i, 1))

Замените русские В на латинские B
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 264 След.
Наверх