sub процедура ()

переменнаяКниги = GetObject(pathBook)
массив = переменнаяКниги.ActiveSheet.UsedRange
переменнаяКниги.Close

....
End sub

 .Range("C" & i) = UBound(arr1) + 1 - z: z = 0

Sub Macro1()
    Dim arr1, arr2
    Dim x As Long, i As Long, z As Integer
    Dim aArr, aArr2
    
    With ThisWorkbook.ActiveSheet
        x = .Cells(Rows.Count, 1).End(xlUp).Row
        arr2 = Split(.Range("C2"), ",")
    
        For i = 3 To x
            arr1 = Split(.Range("B" & i), ";")
            For Each aArr In arr1
                For Each aArr2 In arr2
                    If aArr = aArr2 Then
                       z = z + 1
                    End If
                Next
            Next
            .Range("C" & i) = UBound(arr1) + 1 - z: z = 0
        Next i
    End With
End Sub

Sub Macros1()
Dim x
    For Each x In Sheets("База").Range("E6:DH53")
        If x > 0 Or x.Interior.Color <> xlNone Then
            x.Formula = x.Value
        End If
    Next
End Sub

Sub Macro1()
    Dim x As Long, i As Integer, y As Integer
    Dim lRow As Long
    Dim iCol As Integer
    
    With ThisWorkbook.Worksheets("Аркуш1")
        x = .Cells(Rows.Count, 1).End(xlUp).Row
        i = .Cells(1, Columns.Count).End(xlToLeft).Column
        y = 0
        For lRow = 2 To x
            For iCol = 1 To i
                If .Cells(lRow, iCol).Value = "Запросить" Then
                    y = 1
                    Exit For
                End If
            Next
            If y = 0 Then .Rows(lRow).Hidden = True
            y = 0
        Next
    End With

End Sub

Sub Macro2()
    Dim x As Integer
    
    x = 12 'номер строки с которой начинается таблица

    With ThisWorkbook.Worksheets("Лист1")
        Do While .Range("E" & x) < .Range("B5") 'проходим циклом по столбцу "Е" и сразу проверяем, что значение в ячейке меньше чем в "В5"
            x = x + 1
        Loop
        .Range("B2") = .Range("D" & x)
    End With
    
End Sub

Private Sub Image3_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim pic As Object
    Set pic = CreateObject("PowerPoint.Application")
    pic.Presentations.Open "C:\Users\Desktop\instruction2.ppsx"
    DoEvents
End Sub

tbl(j, 3) = dict(i + 1, 2) + dict(i + 1, 3) + dict(i + 1, 4) 'UROiK2

Sub test()
    Dim shData As Worksheet
    Dim NewWB As Workbook
    Dim iCountDate As Integer
    Dim iLasrColSvod As Integer
    Dim iLasrColData As Integer
    Dim lLastRowData As Long
    Dim i As Integer
    Dim x As Integer
    Dim z As Integer
    Dim iLocat As Integer
    Dim iDeport As Integer
    Dim arrData()
    
    
    
    Set shData = ThisWorkbook.Worksheets("Лист1")
    iLasrColData = shData.Cells(1, Columns.Count).End(xlToLeft).Column
    lLastRowData = shData.Cells(Rows.Count, 1).End(xlUp).Row
    x = 1
        
    ReDim arrData(1 To 10, 1 To 5)
    arrData(1, 1) = "Количество  " & Date
    arrData(2, 1) = "Подразделение"
    arrData(3, 1) = "Нижний Новгород"
    arrData(4, 1) = "Екатеринбург"
    arrData(5, 1) = "Ставрополь"
    arrData(6, 1) = "Омск"
    arrData(7, 1) = "Воронеж"
    arrData(8, 1) = "Волгоград"
    arrData(9, 1) = "Самара"
    arrData(10, 1) = "Итого"
    arrData(2, 2) = "УРОиК1"
    arrData(2, 3) = "УРОиК2"
    arrData(2, 4) = "УРОиК3"
    
       For x = 3 To iLasrColData
            arrData(3, 5) = ""
            arrData(4, 5) = ""
            arrData(5, 5) = ""
            arrData(6, 5) = ""
            arrData(7, 5) = ""
            arrData(8, 5) = ""
            arrData(9, 5) = ""
            For z = 3 To lLastRowData
                If shData.Cells(z, x) <> "" Then
                    For iDeport = 1 To UBound(arrData, 2)
                        If shData.Cells(z, 1) = arrData(2, iDeport) Then
                            For iLocat = 1 To UBound(arrData)
                                If shData.Cells(z, 2) = arrData(iLocat, 1) Then
                                    If arrData(iLocat, 5) = 1 Then
                                        Exit For
                                    Else
                                        arrData(iLocat, iDeport) = arrData(iLocat, iDeport) + 1
                                        arrData(iLocat, 5) = 1
                                    End If
                                 End If
                             Next iLocat
                        End If
                    Next iDeport
                End If
            Next z
       Next x
            arrData(3, 5) = ""
            arrData(4, 5) = ""
            arrData(5, 5) = ""
            arrData(6, 5) = ""
            arrData(7, 5) = ""
            arrData(8, 5) = ""
            arrData(9, 5) = ""
            arrData(10, 2) = "=SUM(R[-7]C:R[-1]C)"
            arrData(10, 3) = "=SUM(R[-7]C:R[-1]C)"
            arrData(10, 4) = "=SUM(R[-7]C:R[-1]C)"

Set NewWB = Workbooks.Add

NewWB.Worksheets(1).Range("A1").Resize(UBound(arrData), UBound(arrData, 2) - 1) = arrData

With NewWB.Worksheets(1)
    For i = 2 To 4
        For x = 3 To 9
            If .Cells(x, i) = "" Then .Cells(x, i) = 0
        Next x
    Next i
    
    .Range("A1").CurrentRegion.Borders.LineStyle = 1
    .Rows(1).Font.Bold = True
    .Rows(2).Font.Bold = True
    .Rows(10).Font.Bold = True
    .Range("A1:D1").Merge
    .Range("A1").Interior.Color = RGB(198, 224, 180)
    .Columns("A:D").EntireColumn.AutoFit
End With

End Sub