Sub InsertColumns()
Dim i As Long
Dim iLastRow As Long
Dim iLastCol As Integer
 iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = iLastCol - 1 To 3 Step -2
    Columns(i).Resize(, 2).Insert
    Range(Cells(1, i), Cells(iLastRow, i + 1)) = 1
  Next
End Sub

Sub iSum()
Dim iLastRow As Long
Dim Rng As Range
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     For Each Rng In Range("A3:A" & iLastRow).SpecialCells(2, 1).Areas
       Rng.Cells(Rng.Count + 1, 2) = WorksheetFunction.Sum(Rng.Offset(, 1))
     Next
End Sub

Function iYear(cell As String)
 With CreateObject("VBScript.RegExp")
     .Pattern = "\d{4}"
     If .Test(cell) Then
       iYear = .Execute(cell)(0)
     Else
       iYear = "данные уточняются"
     End If
 End With
End Function

If Range("B16") = "Н" Then

Sub Fruit()
Dim i As Long
Dim iLastRow As Long
Dim FoundFruit As Range
Dim FAdr As String
 iLastRow = Cells(Rows.Count, "D").End(xlUp).Row
 Range("E2:E" & iLastRow).ClearContents
 Range("E2:E" & iLastRow).NumberFormat = "@"
      For i = 2 To iLastRow
        Set FoundFruit = Columns(2).Find(Cells(i, "D"), , xlValues, xlWhole)
            FAdr = FoundFruit.Address
          Do
            Cells(i, "E") = Cells(i, "E") + Cells(FoundFruit.Row, "A") & ", "
            Set FoundFruit = Columns(2).FindNext(FoundFruit)
          Loop While FoundFruit.Address <> FAdr
             Cells(i, "E") = Left(Cells(i, "E"), Len(Cells(i, "E")) - 2)
      Next
End Sub

Function iEvro(cell$)
 With CreateObject("VBScript.RegExp")
   .Pattern = "\d+\.\d+"
   iEvro = .Execute(cell)(0)
   iEvro = Replace(iEvro, ".", ",") * 1000000
 End With
End Function

Set MV = Worksheets("маты").Columns(1).Find(Target.Value2, , , xlWhole)

Set MV = Worksheets("новый файл.xlsx").Worksheets(1).Columns(1).Find(Target.Value2, , , xlWhole)

Sub PoiskInMassiv()
Dim i As Long
Dim iLastRow As Long
Dim dict As Object
Dim FoundCustomer As Range
Dim FoundMetod As Range
Dim FAdr As String
Dim arr
 iLastRow = Cells(Rows.Count, "O").End(xlUp).Row + 2
   Range("M3:R" & iLastRow).ClearContents
   Set FoundCustomer = Columns("E").Find(Cells(2, "N"), , xlValues, xlWhole)
  If Not FoundCustomer Is Nothing Then
    Set dict = CreateObject("Scripting.Dictionary")
     FAdr = FoundCustomer.Address
     Do
       If Format(FoundCustomer.Offset(, -3), "MMMM") = Range("M2") Then
         arr = Split(FoundCustomer.Offset(, 5), ", ")
         For i = 0 To UBound(arr)
          dict.Item(arr(i)) = dict.Item(arr(i)) + FoundCustomer.Offset(, 2)
         Next
       End If
        Set FoundCustomer = Columns("E").FindNext(FoundCustomer)
     Loop While FoundCustomer.Address <> FAdr
        Range("O3").Resize(dict.Count, 2) = Application.Transpose(Array(dict.Keys, dict.Items))
       For i = 3 To 2 + dict.Count
         Set FoundMetod = Columns("T").Find(Cells(i, "O"), , xlValues, xlWhole)
         Cells(i, "Q") = Cells(i, "P") * FoundMetod.Offset(, 1)
       Next
         Range("R3") = WorksheetFunction.Sum(Range("Q3:Q" & 2 + dict.Count))
  End If
End Sub

'запускать при активном листе расчет
Sub Tsena()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FoundData As Range
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("G3:G" & iLastRow).ClearContents
 With Worksheets("данные")
  For i = 3 To iLastRow
    Set FoundCell = .Columns(3).Find(Cells(i, "A"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       Set FoundData = .Columns(7).Find(What:=Cells(i, "I"), After:=FoundCell.Offset(, 4), _
           LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
       Cells(i, "G") = FoundData.Offset(, 1)
     End If
  Next
 End With
End Sub

.Pattern = "\d{2}(?=\sлет|\sгод)"

    .Pattern = "\b\d{2}\b"

Function iNomer(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "\d{11}"
     If .test(cell) Then
       iNomer = .Execute(cell)(0)
     End If
 End With
End Function
Function iAge(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "\d{1,2}(?=\sлет)"
     If .test(cell) Then
       iAge = .Execute(cell)(0)
     End If
 End With
End Function

Sub GRW()
Dim i As Range, j&, k&
ReDim v(1 To 65000, 1 To 2)
For Each i In [A:A].SpecialCells(xlCellTypeConstants, xlNumbers)
   For j = i To i(, 2)
       k = k + 1
       v(k, 1) = j
       v(k, 2) = i(, 3)
   Next
Next
[E1:F65000].Value = v
End Sub

Sub Tablica()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 1 To iLastRow
    Cells(i, 1).NumberFormat = "@"
    Cells(i, 1) = Cells(i, 1).Text
  Next
End Sub

Sub iNomer()
Dim mo As Object
Dim n As Integer
Dim i As Long
Dim j As Integer
   Range("B1:C2").ClearContents
 With CreateObject("VBScript.RegExp")
   .Global = True
   .Pattern = "\d{5}"
  For i = 1 To 2
     If .test(Cells(i, "A")) Then
       Set mo = .Execute(Cells(i, "A"))
           j = 2
         For n = 0 To mo.Count - 1
           Cells(i, j) = Val(mo(n))
           j = j + 1
         Next
    End If
   Next
 End With
End Sub

Set MV = Workbooks("матывсе.xlsx").WorkSheets(1)

Sub FindDublInTable()
Dim i As Long
Dim iLastRow As Long
Dim cell As Range
 iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
 Range("D1:D" & iLastRow).ClearContents
    For i = 1 To iLastRow
       If Cells(i, "C") <> "" Then
        Set cell = Range("B1:B7").Find(Cells(i, "C"), , xlValues, xlWhole)
        If Not cell Is Nothing Then
          Cells(i, "D") = "строка: " & cell.Row
        End If
       End If
    Next
End Sub

Function iOOO(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "(ООО|ТОВ)\s([А-ЯЁ]+)(?=\s\d)"
     iOOO = .Execute(cell)(0).SubMatches(1)
 End With
End Function

Sub iPhone()
 Dim re As Object
 Dim tempPhone As String
 Dim arr
 Dim cell As Range
 Dim RgxPhone As String
  Set arr = Selection
  Selection.Interior.ColorIndex = xlNone
  For Each cell In arr
    Set re = CreateObject("vbscript.regexp")
    re.Pattern = "(-|\s|\+|\(|\))"
    re.Global = True
    re.IgnoreCase = True
    tempPhone = re.Replace(cell, "")
    re.Pattern = "(8|7)+(\d{3})+(\d{7})"
    RgxPhone = re.Replace(tempPhone, "$2$3")
    If Len(RgxPhone) > 10 Then
     cell.Interior.ColorIndex = 6:
    Else
      If Len(RgxPhone) = 10 Then
        cell = "7" & RgxPhone
      Else
        If Len(RgxPhone) = 7 Then
          Select Case Left(RgxPhone, 3)
          Case "320", "349"
            cell = "495" & RgxPhone
          Case "348", "356", "357"
            cell = "499" & RgxPhone
           End Select
        End If
      End If
    End If
  Next
End Sub

Sub iData()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
    Cells(i, "C") = CDate(Split(Cells(i, "B"), " ")(0))
    Cells(i, "C").NumberFormat = "[$-419]d mmm yyyy;@"
  Next
End Sub