快速堆叠列和移调
经过几天学习VBA，我设法得到一个简单的macros，从一张表中取出一些数据并转换到另一个，然后将这些列堆叠在一起。
macros
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次中的每一次，我复制并转置了3次56列的范围。 这需要一段时间，大约1.5小时。 由于我需要每周运行一次，所以我在问我是否写了一些代码部分…也许我不知道我可以在一些地方种下它…
有什么想法吗？
更新
你的build议后，我得到调整了一些代码，我想知道是否有其他“缺陷”
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
看看这个链接，你可以closures的其他一些东西，如公式重新计算： 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
而且，为什么不使用你的计数器值明确引用你的范围，并避免使用resize和偏移频繁？
另一个想法是，看看是否可以删除将这些列粘贴到新表后的最终操作 – 是否可以在进入循环之前重新排列源数据，也许在macros的顶部？ 这样你将不得不执行一次堆叠而不是7589次。 或者，也可以在循环结束后find合并列的方法。
我的问题的答案是：“使用数组”:)
现在的代码是这样的：
Sub pivotsourcedata() 'Set ScreenUpdating to False Application.ScreenUpdating = False Application.StatusBar = True Dim OppsClosed As Worksheet Set OppsClosed = Worksheets("Opps Closed FY15") Sheets.Add.Name = "Shadow2" Dim Shadow2 As Worksheet Set Shadow2 = Worksheets("Shadow2") Dim ID As Range Dim ID0 As Range Set ID0 = OppsClosed.Range("A13") Dim HeaderSelect As Range Set HeaderSelect = OppsClosed.Range("FB1") Dim DataSelect As Range Set DataSelect = OppsClosed.Range("FC14") Dim RowSize As Integer OppsClosed.Activate Dim lastrow, records, nHeader As Integer lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 13 nHeader = 56 records = lastrow * nHeader 'Stack DataSelect on column C of Shadow 2 ReDim TempTableData(1 To nHeader, 1 To lastrow) As Variant ReDim TempTableHeader(1 To nHeader, 1 To lastrow) ReDim FixedHeaders(1 To nHeader, 1 To 1) ReDim Temp_Array1(1 To records, 1 To 1) As Variant ReDim Temp_Array2(1 To records, 1 To 1) As Variant FixedHeaders = OppsClosed.Range("FC1").Resize(1, nHeader) FixedHeaders = Application.Transpose(FixedHeaders) For j = 1 To lastrow 'Progress bar Application.StatusBar = "Progress: " & j & " of " & lastrow & ": " & Format(j / lastrow, "0%") For i = 1 To nHeader TempTableData(i, j) = DataSelect.Offset(j - 1, i - 1) TempTableHeader(i, j) = FixedHeaders(i, 1) Next i Next j For j = 1 To nHeader For i = 0 To lastrow - 1 Temp_Array1((i * nHeader) + j, 1) = TempTableData(j, i + 1) Temp_Array2((i * nHeader) + j, 1) = TempTableHeader(j, i + 1) Next i Next j Shadow2.Range("C1:C" & records).Value2 = Temp_Array1 Shadow2.Range("B1:B" & records).Value2 = Temp_Array2 'Copy and Replicate ID ReDim TempTableID(1 To records, 1 To 1) k = 1 For i = 1 To records 'Progress bar Application.StatusBar = "Progress: " & i & " of " & records & ": " & Format(i / records, "0%") DoEvents 'FixedID = OppsClosed.Range("A13").Offset(k, 0) TempTableID(i, 1) = OppsClosed.Range("A13").Offset(k, 0) variable = i / nHeader If Fix(variable) = variable Then k = k + 1 End If Next i Shadow2.Range("A1:A" & records).Value2 = TempTableID Application.StatusBar = False Application.ScreenUpdating = True End Sub