Function iTowar(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "[A-Z]\d{1,2}(?=\s?[XХ])"
     iTowar = Left(cell, .Execute(cell)(0).FirstIndex + 1) & " " & Mid(cell, .Execute(cell)(0).FirstIndex + 2)
 End With
End Function

Sub Nomer_TM()
Dim FoundModel As Range
Dim i As Long
Dim iLastRow As Long
  iLastRow = Range("A1").End(xlDown).Row
    Range("B3:C" & iLastRow).ClearContents
  For i = 3 To iLastRow
    Set FoundModel = Columns(6).Find(Split(Cells(i, 1), " ")(0), , xlValues, xlWhole)
    Cells(i, 3) = FoundModel.Offset(, 1)
    Cells(i, 2) = Columns(6).FindNext(FoundModel).Offset(, 1)
  Next
End Sub

Sub iPrice()
Dim i As Long
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim iPrice As String
   Range("C3:C" & iLastRow).ClearContents
 With CreateObject("VBScript.RegExp")
   .Pattern = "\d+\.\d+"
     For i = 3 To iLastRow
      iPrice = .Execute(Cells(i, 1))(0)
      Cells(i, 3) = Cells(i, 1)
      Cells(i, 3).Replace what:=iPrice, replacement:=Left(Cells(i, 2), Len(Cells(i, 2)) - 2)
     Next
 End With
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, 2) = Left(Cells(i, 1), InStrRev(Cells(i, 1), "/") - 1)
  Next
End Sub

Function iText(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
     .Pattern = "[A-Z\d\.]+\b"
   iText = Application.Trim(.Replace(cell, ""))
 End With
End Function

Function iText_(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Pattern = "[A-Z][a-z]"
   iText_ = Mid(cell, .Execute(cell)(0).FirstIndex + 1)
 End With
End Function

Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

  
With Application.FileDialog(msoFileDialogSaveAs)
   If .Show = -1 Then   'кнопка Cancel не нажата
   .Execute
   '
   End If
End With

Sub PerenosUniq()
Dim dicObj As Object
Dim i As Long
Dim FoundNomer As Range
Dim FAdr As String
Dim FDate As Date
Dim EDate As Date
Set dicObj = CreateObject("scripting.dictionary")
  For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
    dicObj.Item(CStr(Cells(i, "D"))) = dicObj.Item(CStr(Cells(i, "D"))) + Cells(i, "G") + Cells(i, "H")  'сумма в dicObj.items
  Next i
With Sheets("что должно быть")
 .Rows("2:" & Cells(Rows.Count, "D").End(xlUp).Row + 1).EntireRow.Delete
 .Range("D2").Resize(dicObj.Count) = Application.Transpose(dicObj.keys)
 .Range("G2").Resize(dicObj.Count) = Application.Transpose(dicObj.Items)
  For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
    Set FoundNomer = Columns(4).Find(.Cells(i, "D"), , xlValues, xlWhole)
    Range("A" & FoundNomer.Row & ":C" & FoundNomer.Row).Copy .Cells(i, "A")
    .Cells(i, "H") = Cells(FoundNomer.Row, "I")
    FAdr = FoundNomer.Address
      FDate = Cells(FoundNomer.Row, "E")
      EDate = Cells(FoundNomer.Row, "F")
      Do
        Set FoundNomer = Columns(4).FindNext(FoundNomer)
        If Cells(FoundNomer.Row, "E") < FDate Then FDate = Cells(FoundNomer.Row, "E")
        If Cells(FoundNomer.Row, "F") > EDate Then EDate = Cells(FoundNomer.Row, "F")
      Loop While FoundNomer.Address <> FAdr
        .Cells(i, "E") = FDate
        .Cells(i, "F") = EDate
  Next
End With
End Sub

Function iText(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .Pattern = "[A-Z \d]+\b"
   iText = .Replace(cell, "")
 End With
End Function

Sub PerenosUniq()
Dim dicObj As Object
Dim i As Long
Dim FoundNomer As Range
Set dicObj = CreateObject("scripting.dictionary")
  For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
    dicObj.Item(CStr(Cells(i, "D"))) = dicObj.Item(CStr(Cells(i, "D"))) + Cells(i, "G") + Cells(i, "H")  'сумма в dicObj.items
  Next i
With Sheets("что должно быть")
 .Rows("2:" & Cells(Rows.Count, "D").End(xlUp).Row).EntireRow.Delete
 .Range("D2").Resize(dicObj.Count) = Application.Transpose(dicObj.keys)
 .Range("G2").Resize(dicObj.Count) = Application.Transpose(dicObj.Items)
  For i = 2 To .Cells(.Rows.Count, "D").End(xlUp).Row
    Set FoundNomer = Columns(4).Find(.Cells(i, "D"), , xlValues, xlWhole)
    Range("A" & FoundNomer.Row & ":C" & FoundNomer.Row).Copy .Cells(i, "A")
    .Cells(i, "H") = Cells(FoundNomer.Row, "I")
  Next
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("A1")) Is Nothing Then
   Application.EnableEvents = False
   Dim FoundCell As Range
     Range("B3:D6").ClearContents
   With Worksheets("Лист2")
        Set FoundCell = .Range("A16:A60").Find(Target, , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          .Range("B" & FoundCell.Row & ":D" & FoundCell.Row + 3).Copy Range("B3")
          Range("I1") = .Cells(FoundCell.Row, "H")
        End If
   End With
 End If
   Application.EnableEvents = True
End Sub

Function iNomer(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .Pattern = "[BPWCСРВ]\d{3}[a-z]?"
   If .Test(cell) Then
     iNomer = .Execute(cell)(0)
     If Left(iNomer, 1) = "С" Then iNomer = "C" & Mid(iNomer, 2)
     If Left(iNomer, 1) = "Р" Then iNomer = "P" & Mid(iNomer, 2)
     If Left(iNomer, 1) = "В" Then iNomer = "B" & Mid(iNomer, 2)
     If Len(iNomer) = 4 Then iNomer = iNomer & " "
   End If
 End With
End Function

.Pattern = "[BPWCСРВ]\d{3}[a-z]?"

Function iNomer(cell$) As String
 With CreateObject("VBScript.RegExp")
   .Global = True
   .IgnoreCase = True
   .Pattern = "[BPWCСРВ]\d+"
   If .Test(cell) Then
     iNomer = .Execute(cell)(0)
     If Left(iNomer, 1) = "С" Then iNomer = "C" & Mid(iNomer, 2)
     If Left(iNomer, 1) = "Р" Then iNomer = "P" & Mid(iNomer, 2)
     If Left(iNomer, 1) = "В" Then iNomer = "B" & Mid(iNomer, 2)
   End If
 End With
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Not Intersect(Target, Columns(1)) Is Nothing Then
    Application.EnableEvents = False
Dim iCell As Double
Dim iDrob As Double
    iCell = Target.Value * 100
    iCell = Fix(iCell)
    iDrob = Application.InputBox("Введите три цифры замены", , Type:=1) / 1000
    iCell = (iCell + iDrob) / 100
    Target = iCell
  End If
    Application.EnableEvents = True
End Sub

.Pattern = "[BPWCСРВ]\d+"