Sub ИН()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("B4:B" & iLastRow).ClearContents
   With CreateObject("VBScript.RegExp")
     .ignorecase = True
     .Pattern = "\(?ИНВ?-? ?\d+"
    For i = 5 To iLastRow
      If .Test(Cells(i, 1)) Then
        Cells(i, 2) = Right(Cells(i, 1), Len(Cells(i, 1)) - .Execute(Cells(i, 1))(0).FirstIndex)
        Cells(i, 1) = Left(Cells(i, 1), .Execute(Cells(i, 1))(0).FirstIndex)
      End If
    Next
   End With
End Sub

Set pInvoice = .Rows(rFndShipNr.Row).Find(rInvoice, pInvoice)

Dim rPayDate As Date, rPayWeek As Range, pInvoice As Range

Range("B" & i & ":J" & i).Copy

Range(Cells(i, "B"), Cells(i, "J")).Copy

Range("B" & CStr(i) & ":J" & i).Copy 

Sheets("Завершенные").Range("B" & lr)

Rows(i).Delete

lr=lr + 1

For i =  Cells(Rows.Count, 4).End(xlUp).Row To 4 Step -1

Sub iCopyDiapazon()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim FoundData As Range
  For Each Sht In Worksheets
    With Sht
      iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
      'ищем ячейку с последней датой (слово Дата)в столбце А
      Set FoundData = .Columns(1).Find("Дата", .Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious)
      .Range("A" & FoundData.Row & ":H" & iLastRow).Copy .Cells(iLastRow + 1, 1)
       .Cells(iLastRow + 2, 1) = .Cells(FoundData.Row + 1, 1) + 1
    End With
  Next
End Sub

Sub UniqPara()
Dim i As Long
Dim iLastRow As Long
Dim dic As Object
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Set dic = CreateObject("scripting.dictionary"): dic.comparemode = 1
  For i = 2 To iLastRow
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) = _
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) + Cells(i, "C") 'сумма в dic.items
  Next
  For i = 2 To iLastRow
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) = _
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) + _
    dic.Item(CStr(Cells(i, "B").Value & "_" & Cells(i, "A").Value))
    dic.Remove CStr(Cells(i, "B").Value & "_" & Cells(i, "A").Value)
  Next
  [D2].Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items))
End Sub

Sub DelDubl()
Dim i As Long
Dim iLastRow As Long
Dim Para As String
Dim ParaRev As String
Dim FoundPoz As Range
Dim iRow As Long
Dim FAdr As String
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow - 1         'проверяем есть ли дубликаты Para и ParaRev
    Para = Cells(i, 1)
    ParaRev = Cells(i, 2)
    Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(Para, , xlValues, xlWhole)
    If Not FoundPoz Is Nothing Then 'нашли Para после Cells(i, 1)
      FAdr = Cells(i, 1).Address
      If Not FoundPoz.Address = FAdr Then    'есть ли еще Para в столбце А
       Do
        If FoundPoz.Offset(, 1) = ParaRev Then
         Cells(i, 3) = Cells(i, 3) + FoundPoz.Offset(, 2)   'есди дубликат, то суммируем кол-во
         Range("A" & FoundPoz.Row & ":C" & FoundPoz.Row).Delete
         iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        End If
        Set FoundPoz = Range("A" & i & ":A" & iLastRow).FindNext(FoundPoz)
       Loop While FoundPoz.Address <> FAdr
      End If
    End If
  Next
  For i = 2 To iLastRow - 1     'проверяем есть ли дубликаты ParaRev и Para
    Para = Cells(i, 1)
    ParaRev = Cells(i, 2)
    Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(ParaRev, , xlValues, xlWhole)
    If Not FoundPoz Is Nothing Then
      FAdr = Cells(i, 1).Address
      If Not FoundPoz.Address = FAdr Then    'есть ли еще ParaRev в столбце А
       Do
        If FoundPoz.Offset(, 1) = Para Then
         iRow = FoundPoz.Row
         Cells(i, 3) = Cells(i, 3) + FoundPoz.Offset(, 2)  'есди обратн. дубликат, то суммируем кол-во
         Range("A" & FoundPoz.Row & ":C" & FoundPoz.Row).Delete
         iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        End If
          If iRow = iLastRow + 1 Then Exit Do
        Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(ParaRev, , xlValues, xlWhole)
       Loop While Not FoundPoz Is Nothing
      End If
    End If
  Next
End Sub

Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim j As Integer
Dim n As Integer
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("B2:M" & iLastRow).Interior.ColorIndex = xlNone
  For i = 2 To iLastRow
    For j = 2 To 13
        n = 0
      Do
        n = n + 1
      Loop While Cells(i, j + n) = Cells(i, j)
            If n >= 3 Then Range(Cells(i, j), Cells(i, j + n - 1)).Interior.ColorIndex = n
        j = j + n - 1
    Next
  Next
End Sub

'в модуль листа НАРЯД
Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Union(Range("L1"), Range("Q4"))) Is Nothing Then
  Application.EnableEvents = False
Dim iDate As Range
Dim FAdr As String
Dim n As Integer
  With Worksheets("ОБЩАЯ")
   Range("B8:Q10").ClearContents
   Range("B4:B6").ClearContents
   Set iDate = .Columns(1).Find(Range("L1"), , xlValues, xlWhole)
   If Not iDate Is Nothing Then
    FAdr = iDate.Address
     n = 8
    Do
      If iDate.Offset(, 3) = Range("Q4") Then   'проверка бригады
        Cells(n - 4, "B") = iDate.Offset(, 4)   'наименование работ
        Cells(n, "B") = iDate.Offset(, 2)        'ФИО
        Cells(n, "Q") = Range("Q4")             'номер бригады
      End If
        If iDate.Offset(, 3) = Range("Q4") Then n = n + 1
      Set iDate = .Columns(1).FindNext(iDate)
    Loop While iDate.Address <> FAdr
   End If
  End With
 End If
  Application.EnableEvents = True
End Sub

Sub Макрос1()
  With Sheets("Результат")
    Range("B7").Copy .Range("K1")   'наименование     критерий фильтрации
    .Range("K2") = "Лук"                  'Лук                     на листе Результат
    Range("A7").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=.Range("K1:K2"), CopyToRange:=.Range("A1:I1"), Unique:=False
    .Range("K1:K2").Clear
  End With
End Sub

c.NumberFormat = "#,##0.00"

c.NumberFormat = "General"

'запускать при активном листе Преобразованная табл
Sub iArticul_Invoice()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
Dim j As Integer
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("B2:G" & iLastRow).ClearContents
 With Worksheets("Исходная табл")
  For i = 2 To iLastRow
     j = 2
    Set FoundCell = .Columns(1).Find(Cells(i, 1), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
         Cells(i, j) = .Cells(FoundCell.Row, 2)
         Set FoundCell = .Columns(1).FindNext(FoundCell)
         j = j + 1
      Loop While FoundCell.Address <> FAdr
     End If
  Next
 End With
End Sub

Sub iConv()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
   If Cells(i, 3).NumberFormat = "#,##0.00 [$€-407];[Red]#,##0.00 [$€-407]" Then
      Cells(i, 3).NumberFormat = "#,##0.00"
   End If
  Next
End Sub

If Selection.NumberFormat = "#,##0.00 [$€-407];[Red]#,##0.00 [$€-407]" Then

Sub iLR_D()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Columns("D").Find("*", Range("D1"), xlValues, xlWhole, xlByColumns, xlPrevious).Row
   i = iLastRow
 Do While Not IsDate(Cells(i, "D"))
   i = i - 1
 Loop
   iLastRow = i
   Cells(i, "D").Select
End Sub

Sub iConvert()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
 iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
   Range("J4:L20").ClearContents
  For i = 4 To iLastRow
     iLR = Cells(Rows.Count, 10).End(xlUp).Row + 1
    Range("C3:G3").Copy
    Cells(iLR, 10).PasteSpecial xlPasteValues, Transpose:=True
    Cells(iLR, 11).Resize(5) = Range("B" & i)
    Range("C" & i & ":G" & i).Copy
    Cells(iLR, 12).PasteSpecial xlPasteValues, Transpose:=True
  Next
End Sub

Sub ВставитьРазрыв()   
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  ActiveSheet.ResetAllPageBreaks
    i = 24
 Do While i < iLastRow
    ActiveSheet.HPageBreaks.Add ActiveSheet.Range("A" & i)
    i = i + 23
 Loop
End Sub

Sub Poisk()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Range("C3:C" & iLastRow).ClearContents
  For i = 3 To iLastRow
    If Not IsEmpty(Cells(i, "A")) Then
     If SheetExist(Cells(i, "B")) Then
      With Worksheets(Cells(i, 2).Text)
       Set FoundCell = .Columns("B").Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          Cells(i, "C") = .Cells(FoundCell.Row, "C")
        End If
      End With
     End If
    End If
  Next
End Sub
Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function

Sub test()
Dim dicObj As Object
Dim i&
Set dicObj = CreateObject("scripting.dictionary")
  Columns("H:I").ClearContents
  For i = 7 To Cells(Rows.Count, "A").End(xlUp).Row
    If Not IsEmpty(Cells(i, "A")) Then
     dicObj.Item(Cells(i, "A").Text) = dicObj.Item(Cells(i, "A").Text) + Cells(i, "F")
    End If
  Next i
    Range("H7").Resize(dicObj.Count) = Application.Transpose(dicObj.keys)    'уникальные из столбца А
    Range("I7").Resize(dicObj.Count) = Application.Transpose(dicObj.Items)   'сумма по столбцу F по уникальным
End Sub