Sub ApplyMacroToAllFiles()
    Dim folderPath As String
    Dim fileName As String
    Dim ws As Worksheet
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            MsgBox "Folder selection canceled.", vbExclamation
            Exit Sub
        End If
    End With
    
    On Error Resume Next
    
    fileName = Dir(folderPath & "\*.xlsx")
    Do While fileName <> ""
        Workbooks.Open folderPath & "\" & fileName
        For Each ws In ActiveWorkbook.Sheets
            RemoveEmptyRows ws
        Next ws
        ActiveWorkbook.Close SaveChanges:=True
        fileName = Dir
    Loop
    
    On Error GoTo 0
End Sub

Sub RemoveEmptyRows(ws As Worksheet)
    Dim rng As Range
    Dim i As Long
    Dim selectedColumns As Range
    Dim selectedColumn As Range
    Dim nonEmptyRows As Range
    Dim destinationSheet As Worksheet
    Dim destinationRow As Long
    Dim area As Range
    
    Set ws = ws
    
    On Error Resume Next
    Set selectedColumns = Application.InputBox("Select the range of columns (use your mouse to select)", Type:=8)
    On Error GoTo 0
    
    If selectedColumns Is Nothing Then
        MsgBox "You did not select a range of columns. The code will be applied to column A.", vbInformation
        Set selectedColumns = ws.Columns("A")
    End If
    
    For Each selectedColumn In selectedColumns.Columns
        Set rng = ws.Columns(selectedColumn.Column)
        For i = 1 To rng.Rows.Count
            If Application.WorksheetFunction.CountA(rng.Rows(i)) <> 0 Then
                If nonEmptyRows Is Nothing Then
                    Set nonEmptyRows = rng.Rows(i)
                Else
                    Set nonEmptyRows = Union(nonEmptyRows, rng.Rows(i))
                End If
            End If
        Next i
    Next selectedColumn
    
    Set destinationSheet = Worksheets.Add
    destinationSheet.Name = "Result (" & Format(Now, "yyyymmdd_hhmmss") & ")"
    
    destinationRow = 1
    For Each area In nonEmptyRows.Areas
        area.Copy Destination:=destinationSheet.Cells(destinationRow, 1)
        destinationRow = destinationRow + area.Rows.Count
    Next area
End Sub

Sub УдалитьПустыеСтроки()
    Dim ws As Worksheet, rng As Range, i As Long, cols As Range, col As Range, nonEmptyRows As Range, destSheet As Worksheet, destRow As Long, area As Range
    Set ws = ActiveSheet
    On Error Resume Next
    Set cols = Application.InputBox("Выберите диапазон столбцов (выделите мышкой)", Type:=8)
    On Error GoTo 0
    If cols Is Nothing Then Set cols = ws.Columns("A")
    
    For Each col In cols.Columns
        Set rng = ws.Columns(col.Column)
        For i = 1 To rng.Rows.Count
            If Application.WorksheetFunction.CountA(rng.Rows(i)) <> 0 Then
                If nonEmptyRows Is Nothing Then
                    Set nonEmptyRows = rng.Rows(i)
                Else
                    Set nonEmptyRows = Union(nonEmptyRows, rng.Rows(i))
                End If
            End If
        Next i
    Next col
    
    Set destSheet = Worksheets.Add
    destSheet.Name = "Результат (" & Format(Now, "yyyymmdd_hhmmss") & ")"
    destRow = 1
    For Each area In nonEmptyRows.Areas
        area.Copy Destination:=destSheet.Cells(destRow, 1)
        destRow = destRow + area.Rows.Count
    Next area
End Sub

Sub p()
    Dim p As String, n As String, e As Object, s As Object
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder Containing Excel Files"
        If .Show = -1 Then
            p = .SelectedItems(1) & "\"
        Else
            MsgBox "Операция отменена.", vbExclamation
            Exit Sub
        End If
    End With
    Set e = CreateObject("Excel.Application"): e.Visible = False
    n = Dir(p & "*.xlsx")
    Do While n <> ""
        With e.Workbooks.Open(p & n)
            For Each s In .Sheets
                s.PageSetup.Zoom = 85
            Next s
            .Save: .Close
        End With
        n = Dir
    Loop
    e.Quit: Set e = Nothing: MsgBox "Масштаб печати изменен на 85 % во всех файлах.", vbInformation
End Sub

=ЕСЛИ(СУММПРОИЗВ(($B3:$B7=F$4)*($A3:$A7=$E5));"есть";"нет")

Sub viewUF()
    UserForm1.TextBox1.Value = StrNumber(Selection.Value)
    UserForm1.Show
End Sub

Public Function StrNumber(StrInput As Variant) As Double
    Dim resultString As String

    For i = 1 To Len(StrInput)
        If IsNumeric(Mid(StrInput, i, 1)) Then resultString = resultString & Mid(StrInput, i, 1)
    Next i

    StrNumber = Val(resultString)
End Function