Question

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

当前代码：

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

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

我选择范围这么大的原因是因为我不知道每个工作表中会出现多少项（行）。列将始终保持不变，但行可能会发生变化。

由于

Answer 1

唐恩！

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

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

我尝试了大约3000行，它在不到10秒的时间内运行;请务必将此宏粘贴到工作簿中的模块中＆＃39; x＆＃39;一旦宏被执行，最好在同一个实例上没有其他工作簿。

告诉我你是否有运气！

Answer 2

一些提示（我想在评论中提出但很难解释）：

您无需复制＆gt;＆gt;过去，使用Copy [destination]参数来做到这一点：
```
y.Sheets("TASK").Range("A3:J3000").Copy x.Sheets("TASKS").Range("A2")
```

您可以使用.CurrentRegion或.End(xlUp)技术，样本找到相当精确的范围：

a）CurrentRegion假设您要复制的范围是连续的并且从Range("A3")开始：

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

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")

Answer 3

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

要查找上次使用的行，请使用此功能。

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

这样可以避免将空行复制到数组中。资料来源：How to determinate the last Row used in VBA including black space in the rows

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

Sub UpdateTable()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'Careful this might prevent the new workbooks from calculating when opened...

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")


'set the values from the P6 output sheets to the workbook

x.Sheets("TASKS").Range("A2:J3000 change this to correct size") = y.Sheets("TASK").Range("A3:J3000")
x.Sheets("TASKS").Range("A3001:J3300 change this to correct size") = w.Sheets("TASK").Range("A3:J300")
x.Sheets("TASKS").Range("A3300:J3600 change this to correct size") = z.Sheets("TASK").Range("A3:J300")

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

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Answer 4

我推荐使用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建议的其中一种方法。查看this SO Q/A了解更多信息。

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

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)
' ...

希望这有帮助！：）

将变量范围附加到数组vba

4 个答案: