Vba 复制部分表并插入N次，然后转置表的第二部分

这是上一篇文章的延续。我能够使公式正常工作，但我的excel在将公式向下拖动60000行后一直崩溃。现在，我正试图找到一种方法，使用VBA来节省内存，从而实现自动化。我发现第一部分很有用，但不知道如何将公式修改为超过3列（我的实际原始数据有45-50列，在不同版本之间有所不同）

样本输入

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  

样本输出：

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

---

因为我对上一篇文章中没有提出vba感到很遗憾，并让OP花时间做了一些不起作用的事情：

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

Sub-trnspose（）
变暗rng As范围
Dim mainArr（）作为变量
将oWs设置为工作表
将tws设置为工作表
Dim dataClmStrt尽可能长
'将月份放入此数组中
mainArr=数组（“1”、“2”、“3”、“4”、“5”、“6”、“7”、“8”、“9”、“10”、“11”、“12”）
设置oWs=Sheets（“Sheet3”）“将数据更改为工作表
将tws=Sheets（“Sheet4”）更改为输出的工作表
与oWs
'查找每月值开始的列。
dataClmStrt=.Range（“1:1”）.Find（“Jan”，.xlPart）.列-1
对于.Range中的每个rng（.Cells（2，1），.Cells（.Rows.Count，1）.End（xlUp））
'跳过任何空白行
如果rng为“”，则
'将数据向下复制12行
tws.Cells（tws.Rows.Count，1）.End（xlUp）.Offset（1）.Resize（12，dataClmStrt）.Value=rng.Resize（，dataClmStrt）.Value
'添加月份数组
tws.Cells（tws.Rows.Count，dataClmStrt+1）。End（xlUp）。Offset（1）。Resize（12，1）。Value=Application.Transpose（mainArr）
"调换月度金额,
tws.Cells（tws.Rows.Count，dataClmStrt+2）。End（xlUp）。Offset（1）。Resize（12，1）。Value=Application.Transpose（rng.Offset（，dataClmStrt）。Resize（，12））
如果结束
下一个rng
以
端接头

欢迎回来，很抱歉听到公式答案不适合您。如果我知道它是60000乘60，我就不会提出公式。但事实上，这并不是一个适合我的网站的代码。查看将范围放入数组，并将数组转换回另一个范围。关于如何取消PIVOT数据可能会有帮助，请参阅VBA方法的选择。再次感谢Scott，非常感谢您的评论，因为它帮助我更清楚地理解了代码！