w = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook.Name)

w = ActiveWorkbook.Name

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count = 1 Then Target = Time
End Sub

With Me.ComboBox1
    .BoundColumn = 2
    Range("A1") = .Value
End With
'или
With Me.ComboBox1
    Range("A1") = .List(.ListIndex, 1)
End With

Application.OnTime TimeValue("00:00:00"), "Мой_макрос"

Sub Удаление_строк()

Dim sSubStr()  'массив условий
Dim li&, I&
Dim arr()
Dim pp As Range
Dim iTemp
    Sheets("Выгрузка").Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Date, "dd.MM_Отчет_за ") & Format(Date - 1, "dd.mm") & ".xlsx"
Application.ScreenUpdating = 0
On Error Resume Next
sSubStr = Array("яблоко", "груша", "слива", "банан", "виноград")
 
With Sheets("Выгрузка")
    arr = .Cells(1, 15).Resize(.UsedRange.Row - 1 + .UsedRange.Rows.Count).Value
End With
 
With CreateObject("Scripting.Dictionary")
    For I = 0 To UBound(sSubStr)
        iTemp = .Item(sSubStr(I))
    Next
    For li = 1 To UBound(arr)
        If .Exists(CStr(arr(li, 1))) Then
            If pp Is Nothing Then
                Set pp = Sheets("Выгрузка").Cells(li, 1)
            Else
                Set pp = Union(pp, Sheets("Выгрузка").Cells(li, 1))
            End If
        End If
    Next li
End With
 
If Not pp Is Nothing Then pp.EntireRow.Delete
Application.ScreenUpdating = 1
ActiveWorkbook.Save
ActiveWindow.Close
End Sub

Dim sSubStr()  'массив условий
Dim li&, I&
Dim arr()
Dim pp As Range
Dim iTemp
Application.ScreenUpdating = 0
On Error Resume Next
sSubStr = Array("яблоко", "груша", "слива", "банан", "виноград")

With Sheets("Выгрузка")
    arr = .Cells(1, 15).Resize(.UsedRange.Row - 1 + .UsedRange.Rows.Count).Value
End With

With CreateObject("Scripting.Dictionary")
    For I = 0 To UBound(sSubStr)
        iTemp = .Item(sSubStr(I))
    Next
    For li = 1 To UBound(arr)
        If .Exists(CStr(arr(li, 1))) Then
            If pp Is Nothing Then
                Set pp = Sheets("Выгрузка").Cells(li + 6, 1)
            Else
                Set pp = Union(pp, Sheets("Выгрузка").Cells(li + 6, 1))
            End If
        End If
    Next li
End With

If Not pp Is Nothing Then pp.EntireRow.Delete
Application.ScreenUpdating = 1
ActiveWorkbook.Save
ActiveWindow.Close

If rCell.Offset(1, 0) <> rCell Then Rows("1:1").Insert

Application.DisplayAlerts = False

Function ИНДЕКСНЕТОЧН(rngCond As Range, iCond As String, Optional rngVal As Range)
Dim arr1(), arr2(), iArr(), I&, J&
ReDim iArr(Application.Caller.Rows.Count, 0)
If rngVal Is Nothing Then Set rngVal = rngCond
arr1 = rngCond.Value
arr2 = rngVal.Value
For I = 1 To UBound(arr1)
    If arr1(I, 1) Like iCond Then
        iArr(J, 0) = arr2(I, 1)
        J = J + 1
    End If
Next
ИНДЕКСНЕТОЧН = iArr
End Function

Sub Borrusale()
    ARR_1 = Range("A2:D11").Value
    ARR_2 = Range("F2:I11").Value
    ARR_2(5, 2) = ARR_1(5, 2)
    Range("K2").Resize(10, 4) = ARR_2
End Sub

=ЕСЛИ(ЕЧИСЛО(O4);"1 пол.";"")

Private Sub Worksheet_Change(ByVal Target As Range)
Dim intCount&
On Error Resume Next
If Target.Count = 1 Then
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    intCount = UBound(Split(Target, "/"))
    With Target.Offset(, 2)
        .Value = Split(Target, "/")(intCount)
        .IndentLevel = intCount
    End With
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

=ВПР(A1;[КНИГА_А.xlsx]Лист1!$A:$AZ;52;0)

Private Sub Workbook_BeforePrint(Cancel As Boolean)
With ActiveSheet
    Set iCl = Intersect(.UsedRange, Union(.Columns("C"), .Columns("K"))).Find("/", , , xlPart)
    If Not iCl Is Nothing Then
        MsgBox "Найден символ '/' !" & vbCrLf & _
                "Печать будет отменена!"
        Cancel = True
    End If
End With
End Sub