How do I copy from each value from a column to specific cell?

Question

I am trying to copy and paste these values into a format our software understands. The order of the number column doesn't change but the location does every time. It could be starting everywhere on A1 for example: 15 is now on A2 but could be on A56 next time.

The numbers

Example of the file:

I am new to vba and this is what I have written so far but this is not efficient at all.

Because the columns never change, and only the rows. I have used find to find the value and move one cell down then copy and paste it into the format on the AU column. The format is as shown:

The only way I can think of is by trying this.

    Cells.Find(What:="ex1", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 0).Select
    Selection.Copy
    Range("AU1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

I hoped this is possible using a loop or a more efficient way to copy those values. The end result needs to look like the format.

Answer 1

This is a very quick way to do it using arrays which make the processing a lot faster

Option Explicit
Public Sub demo()
    Dim InArr As Variant, OutArr As Variant, headers As Variant
    Dim i As Long, j As Long, OutArrCounter As Long

    ' Update with your sheet reference
    With ActiveSheet
        headers = Application.Transpose(Application.Transpose(.Range(.Cells(1, 1), .Cells(1, 9)).Value2))
        InArr = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Value2

        ReDim OutArr(1 To 4, 1 To UBound(InArr, 1) * (UBound(InArr, 2)))
        For i = LBound(InArr, 1) To UBound(InArr, 1)
            For j = LBound(headers) + 1 To UBound(headers)
                OutArrCounter = OutArrCounter + 1

                OutArr(1, OutArrCounter) = 1
                OutArr(2, OutArrCounter) = InArr(i, 1)
                OutArr(3, OutArrCounter) = headers(j)
                OutArr(4, OutArrCounter) = IIf(InArr(i, j) = vbNullString Or Trim(InArr(i, j)) = "-", 0, InArr(i, j))
            Next j
        Next i

        ReDim Preserve OutArr(1 To 4, 1 To OutArrCounter)
        ' Update with your destination
        .Cells(1, 44).Resize(UBound(OutArr, 2), UBound(OutArr, 1)).Value2 = Application.Transpose(OutArr)
    End With
End Sub