Copy Partial Table and Insert N-times, then Transp

Question

This is a continuation from a previous request:. I was able to make the formulas work, but my excel keeps crashing after dragging down the formula for 60,000 rows. Now I'm trying to figure out a way to automate it using VBA to save memory. I've found this thread helpful for the first part but don't know how to modify the formula to more than 3 columns (my actual raw data has 45-50 columns varying between versions).

Sample Input

Col1  Col2 Col3....Col48 Jan($) Feb ($) Mar ($) .... Dec ($) 
111     AAA   CT      a    $55    $100   $125         $100       
112     BBB   NJ      b    $50    $34    $125         $125  
113     CCC   NV      c    $55    $100   $125         $155  
114     DDD   VT      d    $95    $108   $75          $199  
115     EEE   NJ      e    $20    $100   $125         $120  

Sample Output:

Col1 Col2 Col3 ...  Month Spend
111   AAA   CT       1/1   $55
111   AAA   CT       2/1   $100
111   AAA   CT       3/1   $125
111   AAA   CT       4/1   $80
111   AAA   CT       5/1   $70
.
.
.
115   EEE   NJ       11/1  $50
115   EEE   NJ       12/1  $120

Answer 1

Because I feel bad about not suggesting vba in the last post and had the OP spending time on something that would not work:

Sub trnspose()
    Dim rng As Range
    Dim mainArr() As Variant
    Dim oWs As Worksheet
    Dim tws As Worksheet
    Dim dataClmStrt As Long

    'put the months in this array
    mainArr = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12")

    Set oWs = Sheets("Sheet3") 'Change to the sheet with your data
    Set tws = Sheets("Sheet4") 'Change to the sheet for your output

    With oWs
        'find column where monthly values start.
        dataClmStrt = .Range("1:1").Find("Jan", , , xlPart).Column - 1

        For Each rng In .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
            'skip any blank rows
            If rng <> "" Then
                'Copy the data down 12 rows
                tws.Cells(tws.Rows.Count, 1).End(xlUp).Offset(1).Resize(12, dataClmStrt).Value = rng.Resize(, dataClmStrt).Value
                'add the months array
                tws.Cells(tws.Rows.Count, dataClmStrt + 1).End(xlUp).Offset(1).Resize(12, 1).Value = Application.Transpose(mainArr)
                'Transpose the monthly amounts
                tws.Cells(tws.Rows.Count, dataClmStrt + 2).End(xlUp).Offset(1).Resize(12, 1).Value = Application.Transpose(rng.Offset(, dataClmStrt).Resize(, 12))
            End If
        Next rng
    End With

End Sub