Question

这是之前request:的延续。我能够使公式工作，但我的excel在拖动60,000行的公式后不断崩溃。现在我试图想出一种使用VBA来节省内存的自动化方法。我发现this thread对第一部分有帮助，但不知道如何将公式修改为超过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

Answer 1

因为我在上一篇文章中没有提出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

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

1 个答案: