Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim i As Long
ThisWorkbook.Worksheets("List1").Activate
For i = 4 To Cells(Rows.Count, 4).End(xlUp).Row
 If Cells(i, 4).Value <> 0 Then
    Cells(i, 4).Value = Cells(i, 4).Value
 End If
Next i
ThisWorkbook.Save
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim i As Long
ThisWorkbook.Worksheets("List1").Activate
For i = 4 To Cells(Rows.Count, 4).End(xlUp).Row
 If Cells(i, 4).Value <> 0 Then
    Cells(i, 4).Value = Cells(i, 4).Value
 End If
Next i
End Sub

=ИНДЕКС(C3:C12;ПОИСКПОЗ("*";C3:C12;0))

Sub Удалить_таблицы()
    Dim lr As Long
    lr = Cells(Rows.Count, 7).End(xlUp).Row
    Range("20:" & lr + 2).Delete
End Sub

Private Sub CommandButton1_Click()
    If Me.ComboBox1.ListIndex = -1 Then Exit Sub
   ActiveCell = ComboBox1.Value
   Call dorog
End Sub

Sub dorog()
UserForm1.Hide
d = Application.InputBox _
(Prompt:="Сутки на дорогу")
If d = 0 Then [p15] = ""
[p15] = d
End Sub

Sub Poisk_()
    Dim sUslovie
    Dim i As Long
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
    sUslovie = Cells(i, 3).Value
On Error GoTo Dalee
 If Range("A:A").Find(What:=sUslovie).Row Then
    MsgBox "Есть такое слово:  " & Chr(10) & sUslovie
 End If
Dalee:
Next i
End Sub 

Sub Perenos()
    Dim lD&, i
    lD = Left(Date, 2)
For i = 9 To Cells(Rows.Count, 4).End(xlUp).Row
    Cells(i, lD + 5).Value = Cells(i, 4).Value
    Cells(i, 4).ClearContents
Next i
End Sub

Sub Test()
    Dim iCell As Long, i As Long, j As Long, Priznak
    Priznak = Array("c", "a")
    
    For i = 0 To UBound(Priznak)
     For iCell = 1 To Cells(Rows.Count, 1).End(xlUp).Row
         j = Sheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row
      If Cells(iCell, 1) = Priznak(i) Then
         Rows(iCell).Copy Sheets("Лист2").Rows(j + 1)
      End If
     Next iCell
    Next i
End Sub

Range("A1") = Right(Str, Len(Str) - 6)

Range(Cells(i + 1, 2), Cells(j - 1, 2)).Select