将变量范围附加到数组vba

我有一系列的范围，我正在从单独的工作簿复制到一张纸上。目前我正在通过范围复制/粘贴来完成这项工作，但有3本工作簿需要永远更新。 我想将其更改为单个数组，该数组可以从每个工作表中获取已使用的范围，将其附加到数组中，然后将数组psate到我的表中

当前代码：

Sub UpdateTable()
Dim icounter As Long
Dim x As Workbook 'The book we're in
Dim y As Workbook 'The data from P6
Dim z As Workbook
Dim w As Workbook

Set x = ThisWorkbook

Set y = Workbooks.Open("W:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\6011-Activities.xls")
Set z = Workbooks.Open("W:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\6006-Activities.xls")
Set w = Workbooks.Open("W:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\MCR4-Activities.xls")


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'Copy-paste the values from the P6 output sheets to the workbook
y.Sheets("TASK").Range("A3:J3000").Copy

x.Sheets("TASKS").Range("A2").PasteSpecial

Application.CutCopyMode = False

z.Sheets("TASK").Range("A3:J300").Copy

x.Sheets("TASKS").Range("A3001").PasteSpecial

Application.CutCopyMode = False

w.Sheets("TASK").Range("A3:J300").Copy

x.Sheets("TASKS").Range("A3300").PasteSpecial

Application.CutCopyMode = False

'Close the output sheets
y.Close
z.Close
w.Close



Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

正如您所看到的，它有点凌乱，需要很长时间才能运行（考虑到范围的大小，几乎需要整整一分钟）

我之所以选择范围如此之大，是因为我不知道每个工作表中会出现多少项（行）。列将始终保持不变，但行可能会更改

谢谢你提供了一些建议（我想在评论中加以说明，但这些建议很难解释）：

您不需要复制>>过去，使用

Copy[destination]

参数执行以下操作：

y.Sheets("TASK").Range("A3:J3000").Copy x.Sheets("TASKS").Range("A2")

您可以使用

.CurrentRegion

或

.End（xlUp）

技术精确地找到要复制的范围，示例：

a） 使用

CurrentRegion

时，假设要复制的范围是连续的，并且从

范围（“A3”）

开始：

b） 使用

End（xlUp）

假设在A列中有从A3到最后一行的完整数据集：

Dim intLastRowToCopy as integer
    intLastRowToCopy= y.Sheets("TASK").Cells(Rows.Count, "A").End(xlup).Row
y.Sheets("TASK").Range("A3:J" & ntLastRowToCopy).copy x.Sheets("TASKS").Range("A2")

---

不要复制范围，而是将范围设置为新打开工作簿中的范围。它应该工作得更快

要查找最后使用的行，请使用此函数

Function ultimaFilaBlanco(col As String) As Long

    Dim lastRow As Long
    With ActiveSheet
        lastRow = ActiveSheet.Cells(1048576, col).End(xlUp).row
    End With

    ultimaFilaBlanco = lastRow

End Function

这将避免将空行复制到数组中。 资料来源：

然后将每个工作簿的范围复制到单独的数组中。（这将比尝试附加数组快得多。（ReDim.）

邓恩

如果你想要的是效率，我认为有更好的方法，优化你编写的代码，只复制重要的数据；请尝试此代码，它很可能会减少您的处理时间：

Sub UpdateTable()
Dim icounter As Long
Dim x As Workbook 'The book we're in
Dim y As Workbook 'The data from P6
Dim z As Workbook
Dim w As Workbook

Dim WB As Workbook

Set x = ThisWorkbook

Set y = Workbooks.Open("W:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\6011-Activities.xls")
Set z = Workbooks.Open("W:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\6006-Activities.xls")
Set w = Workbooks.Open("W:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\MCR4-Activities.xls")


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'Copy-paste the values from the P6 output sheets to the workbook

For Each WB In Application.Workbooks

    WB.Activate

    If WB.Name <> x.Name Then

        If WB.Name = y.Name Or _
           WB.Name = z.Name Or _
           WB.Name = w.Name Then

            WB.Sheets("TASK").Range(Cells(3, 1), Cells(3, 1).SpecialCells(xlLastCell)).Copy
            x.Activate
            x.Sheets("TASKS").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
       Application.CutCopyMode = False

      End If

    End If

Next

'Close the output sheets
y.Close
z.Close
w.Close



Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic


End Sub

Sub-UpdateTable（）
暗淡的i计数器
将x调暗为工作簿“我们所在的书”
将y作为工作簿“从P6中删除数据”
将z设置为工作簿
将w作为工作簿
将WB设置为工作簿
Set x=此工作簿
设置y=Workbooks.Open（“W:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\6011 Activities.xls”）
设置z=Workbooks.Open（“W:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\6006 Activities.xls”）
设置w=Workbooks.Open（“w:\AOPS\Scheduling\Allan Dunn\P6 Output Folder\MCR4 Activities.xls”）
Application.ScreenUpdating=False
Application.Calculation=xlCalculationManual
'复制将值从P6输出表粘贴到工作簿
对于应用程序中的每个WB。工作簿
WB.激活
如果WB.Name x.Name那么
如果WB.Name=y.Name或_
WB.Name=z.Name或_
WB.Name=w.Name然后
工作表（“任务”）。范围（单元格（3，1）、单元格（3，1）、特殊单元格（xlLastCell））。复制
x、 激活
x、 工作表（“任务”）。范围（“A”和行数）。结束（xlUp）。偏移量（1，0）。粘贴特殊
Application.CutCopyMode=False
如果结束
如果结束
下一个
'关闭输出表
y、 接近
z、 接近
w、 接近
Application.ScreenUpdating=True
Application.Calculation=xlCalculationAutomatic
端接头

我尝试了大约3000行，它在不到10秒内运行；只要确保将此宏粘贴到工作簿“x”中的模块中，并且在执行宏后，最好不要在同一实例上有其他工作簿

---

告诉我你有没有运气

我推荐alphabet5建议的变体

在母版图纸中，保留对要将数据复制到的范围的引用。您可能希望按如下方式对其进行初始化：

dim dstRange as Range
set dstRange = x.Sheets("TASKS").Range("A1")

尽管您可以将“A1”更改为您想要开始输出的任何单元格

接下来，您需要创建一个函数

GetUsedRange

，它接受一个工作表并返回一个覆盖该工作表中所有数据的范围。最简单的版本是：

Function GetUsedRange(ByRef ws as WorkSheet) as Range
    Set GetUsedRange = ws.UsedRange
End Function

请注意，

UsedRange

没有正确的良好声誉，因此我建议使用KazimierzJawor建议的方法之一。查看以了解更多信息

现在，不需要复制和粘贴，只需执行以下操作：

Dim srcRange as Range
' ...
Set srcRange = GetUsedRange(y)
Set dstRange = dstRange.Resize(srcRange.Rows.Count, srcRange.Columns.Count)
dstRange.Value = srcRange.Value
Set dstRange = dstRange.Offset(dstRange.Rows.Count,0)
' ...

---

希望这有帮助！：）

嘿，维巴斯塔德；我尝试了你的代码，发现它的运行时间也一样长，只花了几个月，但它会在excel实例运行时停止它。我希望阵列的运行速度比这快。不过，谢谢。我正在浏览和复习，我发现我的ocde做了一些小改动，加上你的加入，使它运行得更快，总共只需几秒钟！谢谢

Function GetUsedRange(ByRef ws as WorkSheet) as Range
    Set GetUsedRange = ws.UsedRange
End Function

Dim srcRange as Range
' ...
Set srcRange = GetUsedRange(y)
Set dstRange = dstRange.Resize(srcRange.Rows.Count, srcRange.Columns.Count)
dstRange.Value = srcRange.Value
Set dstRange = dstRange.Offset(dstRange.Rows.Count,0)
' ...