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

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

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

re.Pattern = " \(\d+ ?Вт\)"

Private Sub CommandButton1_Click()
Dim arr As Variant
    'Me.TextBox1.Text = "Иванов Иван Иванович"
    arr = Split(Me.TextBox1.Text, " ",2)
    MsgBox arr(1) , 64, "Сообщение"
End Sub

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

adrs = adrs & vbLf & c.Address(0, 0) & ":  " & c.Offset(0, -3)

двух столбцах значение которых, нужно сравнить и найти ошибку

как посчитать сумму этой ячейки

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

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 = 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

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

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

Set Found = ws1.Range("B2:B" & ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row).Find(Numbers2(i, 1))