在学习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小时。因为我需要每周运行它，所以我会问我是否写了一些代码部分......也许我不知道我可以在某些地方播种......
有什么想法吗？
根据你的建议我可以调整一下代码，我想知道是否有其他人＆＃34;瑕疵＆＃34;
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
答案 0 :(得分：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次。或者，或者，找到一种在循环结束后组合列的方法。
答案 1 :(得分：0)
我的问题的答案是：＆＃34;使用数组＆＃34; ：）
现在的代码是：
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