T3853_Transfer Matrix From Sheet To Another Using Arrays

https://excel-egy.com/forum/t3853
---------------------------------

Sub Transfer_Matrix_From_Sheet_To_Another_Using_Arrays()
    Dim a, v, b, ws As Worksheet, sh As Worksheet, i As Long, j As Long, k As Long

    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Input")
        Set sh = ThisWorkbook.Worksheets("Load")

        a = ws.Range("A4").CurrentRegion.Value
        v = Application.Index(ws.Range("F4:P4").Value, 0)
        ReDim b(1 To UBound(a) * UBound(v), 1 To 5)

        For i = LBound(v) To UBound(v)
            For j = 5 To UBound(a)
                If a(j, 1) <> Empty Then
                    If a(j, i + 5) <> Empty Then
                        k = k + 1
                        b(k, 2) = a(4, i + 5)
                        b(k, 3) = a(j, 1)
                        b(k, 5) = a(j, i + 5)
                    End If
                End If
            Next j
        Next i

        sh.Rows("2:" & sh.UsedRange.Rows.Count).ClearContents
        sh.Range("A2").Resize(k, UBound(b, 2)).Value = b
    Application.ScreenUpdating = True
End Sub