vba - 快速堆叠列和转置

Question

在学习 VBA 几天后，我设法获得了一个简单的宏来从一张表中获取一些数据并转置到另一张表中，然后将这些列堆叠在一起。
宏

Sub pivotsourcedata()
    
    Dim HeaderSelect As Range
    Dim DataSelect As Range
    Dim ID As Range
     
    'Variabile Declaration for Progress bar 
        Dim x               As Integer
        Dim MyTimer         As Double


    For i = 1 To 7589
    'Progress bar
        Application.StatusBar = "Progress: " & i & " of 7589: " & Format(i / 7589, "0%")
    
    'Copy ID Range
        Sheets("Opps Closed FY15").Select
        Range("A13").Offset(i, 0).Select
        Set ID = Selection
    'Copy Header Range
        Range("EX13:HA13").Select
        Set HeaderSelect = Selection
    'Copy Data Range
        Range("EX13:HA13").Offset(i, 0).Select
        Set DataSelect = Selection
    'Select ID and copy it to the next sheet and fill it down
        ID.Copy
        Sheets("Sheet1").Select
        If i = 1 Then
        Else
        Selection.Resize(1, 1).Offset(0, 1).Select
        End If
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        Selection.Resize(HeaderSelect.Columns.Count).FillDown
    
    'Select the Header, copy it in the adjacent column    
        Selection.Resize(1, 1).Select
        Selection.Offset(0, 1).Select
        Sheets("Opps Closed FY15").Select
            HeaderSelect.Copy
            Sheets("Sheet1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
                
    'Same for the data, copy to the right of Header        
        Selection.Resize(1, 1).Select
        Selection.Offset(0, 1).Select
        Sheets("Opps Closed FY15").Select
            DataSelect.Copy
            Sheets("Sheet1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
            
    'Stack the columns one over the other 3 by 3.
    ' take the 4th, 5th and 6th columns and stuck'em
    ' below 1st, 2nd and 3rd
    If i = 1 Then
    
    Else
        Range("A1:C1").Offset(56 * (i - 1), 0).Resize(56, 3).Select
        Dim PasteSelect As Range
        Set PasteSelect = Selection
        Range("D1:F56").Select
        Selection.Cut Destination:=PasteSelect
        Selection.Resize(1, 1).Offset(0, -1).Select
    End If
    
    Next i
    
    Application.StatusBar = False

End Sub

正如您所看到的，对于 7589 次中的每一次，我在 56 列的范围内复制并转置了 3 次。这需要一段时间，大约 1.5 小时。因为我需要每周运行它，所以我问我是否写得很糟糕的一些代码部分......也许我不知道我可以在某些领域播种它......
有什么想法吗？
更新
根据您的建议，我对代码进行了一些调整，我想知道是否还有其他“缺陷”

Sub pivotsourcedata()

    Dim OppsClosed As Worksheet
        Set OppsClosed = Worksheets("Opps Closed FY15")
    Dim Shadow2 As Worksheet
        Set Shadow2 = Worksheets("Shadow2")
    Dim ID As Range
    Dim ID0 As Range
        Set ID0 = OppsClosed.Range("A14")
    Dim HeaderSelect As Range
        Set HeaderSelect = OppsClosed.Range("EX13:HA13")
    Dim DataSelect As Range
        Set DataSelect = HeaderSelect
    Dim PasteSelect As Range
    Dim PasteSelect0 As Range
        Set PasteSelect0 = Shadow2.Range("A1:C1").Resize(56, 3)
    Dim CopySelect As Range
        Set CopySelect = Shadow2.Range("D1:F56")
    Dim Inizialize As Range
        Set Inizialize = Shadow2.Range("D1:D1")
    
    'Variabile Declaration for Progress bar
        Dim x               As Integer
        Dim MyTimer         As Double

    'Set ScreenUpdating to False
        Application.ScreenUpdating = False
    
    For i = 1 To 7589
    'Progress bar
        Application.StatusBar = "Progress: " & i & " of 7589: " & Format(i / 7589, "0%")
    
    'Copy ID Range
        Set ID = ID0.Offset(i, 0)
        
    'Copy Data Range
        Set DataSelect = HeaderSelect.Offset(i, 0)

    'Select ID and copy it to the next sheet and fill it down
        ID.Copy
        Shadow2.Select
        
        If i = 1 Then
            Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
            Range("A1").Resize(HeaderSelect.Columns.Count).FillDown
        Else
            Range("D1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
            Range("D1").Resize(HeaderSelect.Columns.Count).FillDown
        End If

    'Select the Header, copy it in the adiacent column
        HeaderSelect.Copy
        If i = 1 Then
            Shadow2.Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
        Else
            Shadow2.Range("E1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
        End If
        
                
    'Same for the data, copy to the right of Header
        DataSelect.Copy
        If i = 1 Then
                Shadow2.Range("C1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=True
        Else
                Shadow2.Range("F1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
                    False, Transpose:=True
        End If
        
            
    'Stack the columns one over the other 3 by 3.
    ' take the 4th, 5th and 6th columns and stuck'em
    ' below 1st, 2nd and 3rd
        If i = 1 Then
        Else
            Set PasteSelect = PasteSelect0.Offset(HeaderSelect.Columns.Count * (i - 1), 0)
            Shadow2.Range("D1:F56").Cut Destination:=PasteSelect
        End If
    
    Next i
    
    Application.StatusBar = False660858
    'Set ScreenUpdating to True
        Application.ScreenUpdating = True

End Sub

Answer 1

查看此链接以了解您可以关闭的其他一些内容，例如公式重新计算:http://datapigtechnologies.com/blog/index.php/ten-things-you-can-do-to-speed-up-your-excel-vba-code/
我同意多重选择是不必要的，并且可能会显着减慢代码速度。在许多情况下，它们可以简单地组合 - 如使用

Selection.Resize(1, 1).Offset(0, 1).Select

代替

Selection.Resize(1, 1).Select
Selection.Offset(0, 1).Select

但是，为什么不使用您的计数器值明确引用您的范围，并避免如此频繁地使用调整大小和偏移量呢？

另一个想法是看看您是否可以删除在将列粘贴到新工作表后堆叠列的最终操作 - 是否可以重新排列源数据，也许在进入循环之前在宏的顶部？这样你就必须执行一次堆叠而不是 7589 次。或者，另一种方法是在循环结束后找到一种方法来组合列。