Макрос переноса данных из одного документа в другой - VBA - Ответ 14288556

Sub Main()
    Dim shG As Worksheet: Set shG = Workbooks("Актуальный график.xlsm").Worksheets("Лист1")
    Dim shT As Worksheet: Set shT = Workbooks("Табельный.xlsm").Worksheets("Табель")
     
    Dim dic As Object:    Set dic = GetDic(shG)
    OutDic shT, dic
End Sub
 
Function GetDic(sh As Worksheet) As Object
    Dim y As Long
    Dim x As Byte
    Dim a As Variant
    Dim g As Variant
    Dim g15 As Variant
    Dim g31 As Variant
    With sh
        y = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
        a = .Range(.Cells(1, 1), .Cells(y, 5))
        x = .Cells(4, .Columns.Count).End(xlToLeft).Column
        g = .Range(.Cells(1, [g4].Column), .Cells(y, .Columns.Count).End(xlToLeft))
    End With
    Dim dic As Object:    Set dic = CreateObject("Scripting.Dictionary")
    Dim arr3(1 To 1, 1 To 3) As Variant
    For y = 19 To UBound(a, 1)
        If Not IsEmpty(a(y, 1)) Then
            For x = 1 To 3
                arr3(1, x) = a(y, x ^ 2 - 2 * x + 2)
            Next
            ReDim g15(1 To 1, 1 To 15)
            ReDim g31(1 To 1, 16 To 31)
            For x = 1 To UBound(g, 2)
                If IsNumeric(g(4, x)) Then
                    If g(4, x) > 0 Then
                        If g(4, x) <= 15 Then
                            g15(1, g(4, x)) = g(y + 2, x)
                        ElseIf g(4, x) <= 31 Then
                            g31(1, g(4, x)) = g(y + 2, x)
                        End If
                    End If
                End If
            Next
            dic.Item(a(y, 1)) = Array(arr3, g15, g31)
        End If
    Next
    If dic.Exists("") Then dic.Remove ("")
    Set GetDic = dic
End Function
'
Sub OutDic(sh As Worksheet, dic As Object)
    With sh
        Dim x As Byte
        Dim y As Long
        Dim yMax  As Long
        Dim i As Long
        Dim a As Variant
      
        yMax = .Cells(.Rows.Count, 1).End(xlUp).Row
        y = 19
        For i = 1 To dic.Count
            If y > 19 Then .Rows("19:20").Copy .Cells(y, 1) 'Заполнение новых строк.
            a = dic.Items()(i - 1)
            .Cells(y + 0, 1).Resize(1, 3).Value = a(LBound(a) + 0)
            .Cells(y + 1, 4).Resize(1, 15).Value = a(LBound(a) + 1)
            .Cells(y + 1, 20).Resize(1, 16).Value = a(LBound(a) + 2)
            y = y + 2
        Next
        Do
            If y > yMax Then Exit Do
            For x = 1 To 3
                .Cells(y, x).Resize(2, 1).ClearContents
            Next
            y = y + 2
        Loop
    End With
End Sub