Function iText(cell As String, j As Integer) As String
Dim mo As Object
Dim n As Integer
   With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = True
     .Pattern = "[^-]+"
    If .Test(cell) Then
      Set mo = .Execute(cell)
      For n = mo.Count - j To mo.Count - 1
        iText = iText & mo(n) & "-"
      Next
        iText = Left(iText, Len(iText) - 6)
    End If
   End With
End Function

Sub XlebBaton()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
 Range("F5:U" & iLastRow).ClearContents
  For i = 5 To iLastRow
    If InStr(1, Cells(i, "E"), "Хлеб") > 0 Then
      Cells(i, "F").Resize(, 2 * Left(Split(Cells(i, "E"), "+ ")(1), 1)) = "Хлеб"
    End If
    If InStr(1, Cells(i, "E"), "Батон") > 0 Then
      Cells(i, "F").Resize(, 2 * Left(Split(Cells(i, "E"), "+ ")(1), 1)) = "Батон"
    End If
  Next
End Sub

Sub iTextColor()
Dim ptn
Dim i As Integer
Dim iLR As Long
Dim objMatch As Object
 With CreateObject("VBScript.RegExp")
   .Global = True
   .ignorecase = True
  iLR = Cells(Rows.Count, "D").End(xlUp).Row
      Columns("D:D").Font.ColorIndex = 0
      ptn = Array("цена", "этаж", "район")
    For i = 0 To UBound(ptn)
      .Pattern = ptn(i)
      If .test(Cells(7, "D")) Then
       Set objMatch = .Execute(Cells(7, "D"))(0)
           With Cells(7, "D").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
              .ColorIndex = 3
           End With
      End If
   Next
 End With
End Sub

Sub iText()
Dim i As Long
Dim iLR As Long
Dim re As Object
Dim objMatches As Object
Dim objMatch As Object
  iLR = Cells(Rows.Count, "D").End(xlUp).Row
      Columns("D:D").Font.ColorIndex = 0
'  For i = 1 To iLR
      Set re = CreateObject("VBScript.RegExp")
         re.Global = True
         re.IgnoreCase = True
         re.Pattern = "цена"
        Set objMatches = re.Execute(Cells(7, "D"))
          If objMatches.Count <> 0 Then
             For j = 0 To objMatches.Count - 1
                Set objMatch = objMatches.Item(j)
                With Cells(7, "D").Characters(Start:=objMatch.FirstIndex + 1, Length:=objMatch.Length).Font
                    .ColorIndex = 3
                End With
             Next
          End If
        Set re = Nothing
'    Next
End Sub

Function iPasport(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "^.+\d{2}\s\d{2}"
     If .Test(cell) Then
       iPasport = .Execute(cell)(0)
     Else
       iPasport = ""
     End If
 End With
End Function

Function iSer(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{2}\s\d{2}"
     If .Test(cell) Then
       iSer = .Execute(cell)(0)
     Else
       iSer = ""
     End If
 End With
End Function

Function iВыдан(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{2}\.\d{2}\.\d{4}.+$"
     If .Test(cell) Then
       iВыдан = Mid(.Execute(cell)(0), 12)
     Else
       iВыдан = ""
     End If
 End With
End Function

Sub Сума()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B3:B" & iLastRow).ClearContents
  iLastRow = Cells(Rows.Count, "E").End(xlUp).Row
 For i = 3 To iLastRow
    Set FoundCell = Columns(1).Find(Cells(i, "E"), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       FoundCell.Offset(, 1) = Cells(i, "F")
     End If
 Next
End Sub

Function iRev(cell$)
 With CreateObject("VBScript.RegExp")
 Dim mo As Object
 Dim i As Integer
    .Global = True
    .Pattern = "[^,]+"
     Set mo = .Execute(cell)
     For i = mo.Count - 1 To 0 Step -1
       iRev = iRev & mo(i) & ","
     Next
     iRev = Left(iRev, Len(iRev) - 1)
 End With
End Function

Function iStrReverse(cell As String) As String
Dim temp
Dim i As Integer
  temp = Split(cell, ",")
  For i = UBound(temp) To 0 Step -1
    iStrReverse = iStrReverse & temp(i) & ","
  Next
    iStrReverse = Left(iStrReverse, Len(iStrReverse) - 1)
End Function

Function iHome(cell$)
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "\d+(/\d+)?[А-Г ]?(\s?СТР)?\.?$"
     iHome = .Execute(cell)(0)
 End With
End Function
Function iStreet(cell$)
 With CreateObject("VBScript.RegExp")
     .IgnoreCase = True
     .Pattern = "\d+(/\d+)?[А-Г ]?(\s?СТР)?\.?$"
     iStreet = .Replace(cell, "")
 End With
End Function

.Pattern = "[A-Z]{1}[a-z,\u00E8-\u00E9]+"

    Range("C" & i + 1 & ":C" & i + 29).EntireRow.Hidden = True

Sub Insert_30()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
  For i = iLastRow To 24 Step -1
    Rows(i + 1).Resize(29).Insert
    Range("C" & i & ":C" & i + 29).MergeCells = True
  Next
End Sub

Sub iCopy()
   Range("C1").Copy
   Workbooks("Файл2.xlsx").Worksheets("Лист1").Range("C1").Resize(Range("C1").MergeArea.Count).PasteSpecial xlPasteValues
End Sub

 Range(Cells(i, 2), Cells(i, iLastCol)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft

If iLastCol > 1 Then

If WorksheetFunction.CountA(Range(Cells(i, 2), Cells(i, iLastCol))) < iLastCol - 1 Then

Sub iDelEmpty()
Dim i As Long
Dim iLastRow As Long
Dim iLastCol As Integer
Dim j As Integer
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 For i = 1 To iLastRow
   iLastCol = Cells(i, Columns.Count).End(xlToLeft).Column
  If iLastCol > 1 Then
    Range(Cells(i, 2), Cells(i, iLastCol)).SpecialCells(xlCellTypeBlanks).Delete
   End If
 Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, Range("A1:A1000")) Is Nothing Then
    Application.EnableEvents = False
Dim Oblast As Range
Dim i As Integer
    With Worksheets("Лист1")
      Set Oblast = .Columns(1).Find(Target, , xlValues, xlWhole)
        If Not Oblast Is Nothing Then
            i = Oblast.Row
          Do
            i = i - 1
          Loop While .Cells(i, "A").Interior.ColorIndex = -4142
        End If
        Target.Offset(, 1) = .Cells(i, "A")
    End With
 End If
    Application.EnableEvents = True
End Sub

Sub Spisok_3()
Dim iLastRow As Long
Dim iLR As Long
Dim iFirstRow As Long
Dim n As Integer
Dim k As Integer
Dim Shapka As Range
  n = 48    'число строк с данными на страницу
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
With Worksheets("Лист2")
  Range("A2:C2").Copy Range("D2").Resize(, 6)
  Set Shapka = Range("A2:I2")
    iFirstRow = 3
    .Cells.Clear
    iLR = 2
  Do
   Shapka.Copy .Cells(iLR, "A")
    For k = 0 To 2
      Range(Cells(iFirstRow + n * k, "A"), Cells(iFirstRow + n - 1 + n * k, "C")).Copy
      .Cells(iLR + 1, 3 * k + 1).PasteSpecial xlValues
    Next
     iLR = .Cells(.Rows.Count, "A").End(xlUp).Row + 2
     iFirstRow = iFirstRow + n * k
  Loop While iFirstRow < iLastRow
  .Activate
End With
End Sub

Просто потом оказывается, то у ТС дата в типа такого: "Начато 31.08.2020"

Function iDate(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "(\d{1,2})\.(\d{1,2})\.(\d{2,4})"
     If .Test(cell) Then
       iDate = .Replace(cell, "$3.$2.$1.")
     Else
       iDate = ""
     End If
 End With
End Function