Sub iClearDann()
Dim iLastCol As Integer
Dim j As Long
  iLastCol = Cells(14, Columns.Count).End(xlToLeft).Column
   For j = iLastCol To 2 Step -1
     If Cells(14, j).Value Mod Range("C6") > 0 And Cells(14, j).Value Mod Range("C6") <= Range("C7") Then
       Cells(16, j).ClearContents
     End If
   Next
End Sub

Sub Макрос1()
n = Range("c6")
m = Range("c7")
i = 1
For Each c In Range(Cells(14, 2), Cells(14, Cells(14, Columns.Count).End(xlToLeft).Column))
    If i > n Then i = 1
    If i <= m Then c.Offset(2, 0) = ""
    i = i + 1
Next
End Sub

If i <= m Then c.Offset(2, 0) = ""

For Each c In Range(Cells(14, 2), Cells(14, Cells(14, Columns.Count).End(xlToLeft).Column))

Sub DelDann()
Dim iLastCol As Integer
Dim j As Long
  iLastCol = Cells(5, Columns.Count).End(xlToLeft).Column
   For j = iLastCol To 2 Step -1
     If Cells(5, j).Value Mod Range("B2") > 0 And Cells(5, j).Value Mod Range("B2") <= Range("B3") Then
       Columns(j).Delete
     End If
   Next
End Sub

Sub iKol_vo_LastDate()
Dim iLastName As Range
  Set iLastName = Columns("B").Find(Cells(2, 5), Range("B1"), xlValues, xlWhole, xlByRows, xlPrevious)
  Cells(2, 6) = iLastName.Offset(, 1)
End Sub

Function iFIO(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "[а-яё]"
   If .test(cell) Then
     iFIO = .Replace(cell, "*")
   End If
 End With
End Function

Sub TEST_()
  Application.ScreenUpdating = False
  Dim rest, sh&, iCell As Range
  rest = Array("Атриум", "Большая Никитская", "Геленджик", "Анапа")
  For sh = 0 To UBound(rest)
   If SheetExist(CStr(rest(sh))) Then
    With Worksheets(rest(sh))
      .Range("A6:I10000").Clear
      For Each iCell In Range("B2", [B2].End(xlDown)) 'цикл по всем ячейкам B2 и ниже
        If iCell = rest(sh) Then
          iCell.EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End If
      Next iCell
    End With
   Else
     MsgBox "В книге нет листа с именем: " & rest(sh)
   End If
  Next
  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

iCell.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, "A")

Sub test()
Dim mo As Object
Dim j As Integer
 With CreateObject("vbscript.regexp")
         .Global = True
     .Pattern = "\+"
          Set mo = .Execute(Cells(1, "A"))
     If mo.Count Then
         For j = 0 To mo.Count - 1
           Cells(1, 2 + j) = mo.Item(j).firstindex + 1
         Next
     End If
 End With
End Sub

    Dim iLastRow As Long
      iLastRow = Range("G10").End(xlDown).Row
.......................................................................
      xSheet.Range("D" & iLastRow + 2 & ":I" & iLastRow + 8).ClearContents

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