Перенос данных на другие листы

Sub Макрос1()
 
  Sheets("Лист для выгрузки").Select
    ActiveSheet.Range("$A$1:$I$1000").AutoFilter Field:=8, Criteria1:= _
        "40262563000, г. Санкт-Петербург"
    Range("B2").Select
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(19, 1)).Select
    Selection.Copy
    Sheets("Опись").Select
    Range("B27:C46").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Лист для выгрузки").Select
    Range("D2").Select
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(19, 0)).Select
    Selection.Copy
    Sheets("Опись").Select
    Range("E27:E46").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        ' Далее следует то же самое для других кодов и районов:
        
        Sheets("Лист для выгрузки").Select
    ActiveSheet.Range("$A$1:$I$1000").AutoFilter Field:=8, Criteria1:= _
        "40263561000, г. Санкт-Петербург"
    Range("B2").Select
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(19, 1)).Select
    Selection.Copy
    Sheets("Опись").Select
    Range("B63").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Лист для выгрузки").Select
    Range("D2").Select
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(19, 0)).Select
    Selection.Copy
    Sheets("Опись").Select
    Range("E63").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
         ' И т.д. Заканчивается переносом в журнал:
        
        ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1
        
    Sheets("Лист для выгрузки").Select
    ActiveSheet.Range("$A$1:$I$1000").AutoFilter Field:=8
    Range("A2:G200").Select
    
    Selection.Copy
    Sheets("Журнал на сайт").Select
    Range("B2:H200").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

Dim ws1 As Worksheet, ws2 As Worksheet, r As Range, c&, i&, a
Set ws1 = Worksheets("Лист для выгрузки") 'Лист1
Set ws2 = Worksheets("Опись") 'Лист2
 
a = Array("40262563000", "40263561000", "40265561000")
For i = 1 To UBound(a)
    If Application.CountIf(ws1.Range("H:H"), a(i) & "*") Then
       ws1.Range("A:H").AutoFilter 8, a(i) & "*"
       Set r = ws1.AutoFilter.Range
       With r
            .Resize(.Rows.Count - 1).Offset(1).Columns(2).Copy
       End With
       ws2.Cells(c * 36 + 27, "B").PasteSpecial
       c = c + 1
    End If
Next

Dim ws1 As Worksheet, ws2 As Worksheet, t$, i1&, i2&, i3&, a1, a2, a3(19, 3)
Set ws1 = Worksheets("Лист для выгрузки") 'Лист1
Set ws2 = Worksheets("Опись") 'Лист2
 
a1 = Array("40262563000", "40263561000", "40265561000")
With ws1
     '.AutoFilterMode = False
     If .FilterMode Then .ShowAllData
     a2 = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "H").End(xlUp)).Value
End With
 
For i1 = 0 To UBound(a1)
    t = a1(i1) & "*"
    For i2 = 1 To UBound(a2)
        If a2(i2, 8) Like t Then
           a3(i3, 0) = a2(i2, 2)
           a3(i3, 1) = a2(i2, 3)
           a3(i3, 3) = a2(i2, 4)
           i3 = i3 + 1: If i3 = 20 Then Exit For
        End If
    Next
    ws2.Cells(i1 * 36 + 27, "B").Resize(20, 4) = a3: Erase a3: i3 = 0
Next

For i4 = (22, 55)
If ws2.Cells(46, 2) > 0 Then
ws2.Cells(i4, 8).Copy Cells(i4, 15)
End If
Next

Private Sub Test()
    Dim t$, i1&, i2&, i3&, i4&, a1, a2, a3(19, 3)
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Лист для выгрузки") 'Лист1
    Set ws2 = Worksheets("Опись") 'Лист2
 
    a1 = Array("40262563000", "40263561000", "40265561000")
    With ws1
         '.AutoFilterMode = False
         If .FilterMode Then .ShowAllData
         a2 = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "H").End(xlUp)).Value
    End With
 
    For i1 = 0 To UBound(a1)
        t = a1(i1) & "*"
        For i2 = 1 To UBound(a2)
            If a2(i2, 8) Like t Then
               a3(i3, 0) = a2(i2, 2)
               a3(i3, 1) = a2(i2, 3)
               a3(i3, 3) = a2(i2, 4)
               i3 = i3 + 1
               If i3 = 20 Then pseudoCopy ws2, a3, i3, i4
            End If
        Next
        If i3 Then pseudoCopy ws2, a3, i3, i4
    Next
End Sub
 
Private Sub pseudoCopy(ws2 As Worksheet, a3, i3&, i4&)
    ws2.Cells(i4 * 36 + 27, "B").Resize(20, 4) = a3
    Erase a3: i3 = 0: i4 = i4 + 1
End Sub