将几个范围堆叠到一个dynamic数组中

希望我的措辞是正确的…

我在网上发现一些事情，说复制和粘贴浪费宝贵的时间。 最好直接分配值，而不使用excel函数。

我在VBA书中find了一个解释如何在二维数组中存储范围的部分。

现在，如果我想用这种方法将dynamic数量的工作表复制并粘贴到另一个主工作表中，该怎么办？

在我的脑海里，我想像一个数组中堆叠越来越多的值，然后将我想要的数组倾倒到一个范围内，这个范围的大小由大数组的维数定义。

在实践中，我设法创造的东西就像下面这样，依次为每个工作表执行相同的简单操作。

有没有可能做得更好？ 那跑得快？ 帮兄弟出去！

Sub arrayCopyPaste() Dim Obj As Range Dim Data As Variant Dim ws As Worksheet Dim sheetCount As Integer Dim LR As Integer sheetCount = Sheets.Count Set ws = Sheets.Add ws.Move After:=Worksheets(Worksheets.Count) For i = 1 To sheetCount Data = Sheets(i).Range("A1:B9") LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row Set Obj = ws.Range("A" & LR) Set Obj = Obj.Resize(UBound(Data, 1), UBound(Data, 2)) Obj.Value = Data Next i End Sub 

Answer 1

几乎所有我使用的代码，我喜欢打电话给我做的这个例程：

 Sub SpeedupCode(Optional ByVal Val As Boolean = True) With Application If Val = True Then .ScreenUpdating = False .Calculation = xlCalculationManual Else .ScreenUpdating = True .Calculation = xlCalculationAutomatic End If End With End Sub 

所以，在你的代码中，你可以简单地使用它，如下所示：

 Sub arrayCopyPaste() Dim Obj As Range Dim Data As Variant Dim ws As Worksheet Dim sheetCount As Integer Dim LR As Integer SpeedupCode sheetCount = Sheets.Count Set ws = Sheets.Add ws.Move After:=Worksheets(Worksheets.Count) For i = 1 To sheetCount Data = Sheets(i).Range("A1:B9") LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row Set Obj = ws.Range("A" & LR) Set Obj = Obj.Resize(UBound(Data, 1), UBound(Data, 2)) Obj.Value = Data Next i SpeedupCode False End Sub 

虽然这不一定会优化您的代码，但它可以显着提高您所做的每个项目的性能。 如果您的代码需要在您的工作表中新计算的variables，则可以在抓取该variables之前始终使用Application.Calculate ，但通常不需要。

Answer 2

我会倾向于使用你目前的方法，并把它煮一点。

 Sub arrayCopyPaste() Dim ws As Worksheet Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count)) For i = 1 To Sheets.Count - 1 With Sheets(i).Range("A1:B9") ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize( _ .Rows.Count, .Columns.Count).Value = .Value End With Next i End Sub 

Answer 3

这个版本稍微高效一点，因为一次写完所有的结果，尽pipe你可能不会注意到很大的区别，除非你使用的是非常大的范围。

 Sub test() 'Same as original: final array is 2 columns wide, (3 * number of sheets) rows long Call mergeRangeValues("A1:B3", "Results", True) 'Alternate version: final array is 3 rows long, (2 * number of sheets) columns wide 'Call mergeRangeValues("A1:B3", "Results", False) End Sub Sub mergeRangeValues(rngString As String, newWSName As String, stackRows As Boolean) 'Merges the same range (rngString) from all sheets in a workbook 'Adds them to a new worksheet (newWSName) 'If stackRows = True, values are stacked vertically 'If stackRows = False, values are stacked horizontally Dim sheetCount As Long Dim newWS As Worksheet sheetCount = ThisWorkbook.Sheets.Count Set newWS = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(sheetCount)) newWS.Name = newWSName Dim numCols As Long Dim numRows As Long numCols = newWS.Range(rngString).Columns.Count * IIf(stackRows, 1, sheetCount) numRows = newWS.Range(rngString).Rows.Count * IIf(stackRows, sheetCount, 1) ReDim resultsArr(1 To numRows, 1 To numCols) As Variant '''Longer version: 'If stackRows Then 'numCols = newWS.Range(rngString).Columns.Count 'numRows = newWS.Range(rngString).Rows.Count * sheetCount 'Else 'numCols = newWS.Range(rngString).Columns.Count * sheetCount 'numRows = newWS.Range(rngString).Rows.Count 'End If '''ie "If you want to stack the results vertically, make the array really long" '''or "If you want to stack the results horizontally, make the array really wide" Dim i As Long For i = 0 To sheetCount - 1 Dim tempArr As Variant tempArr = ThisWorkbook.Sheets(i + 1).Range(rngString).Value Dim j As Long Dim k As Long If stackRows Then For j = LBound(tempArr, 1) To UBound(tempArr, 1) For k = LBound(tempArr, 2) To UBound(tempArr, 2) resultsArr(j + i * (numRows / sheetCount), k) = tempArr(j, k) Next Next Else For j = LBound(tempArr, 1) To UBound(tempArr, 1) For k = LBound(tempArr, 2) To UBound(tempArr, 2) resultsArr(j, k + i * (numCols / sheetCount)) = tempArr(j, k) Next Next End If Next With newWS .Range(.Cells(1, 1), .Cells(numRows, numCols)).Value = resultsArr End With End Sub