Excel VBA 将范围复制到 1,048,576 行后的新工作表

Posted 2023-02-24

【中文标题】Excel VBA 将范围复制到 1,048,576 行后的新工作表

【英文标题】：Excel VBA copy range to a new sheet after 1,048,576 rows

【发布时间】：2016-07-08 09:28:26

【问题描述】：

所以我在 VBA 中编写了一个相当简单的宏来更新一组变量，然后将更新后的值复制并粘贴到一个新工作表中。问题是现在卷有点压倒了，因此在 Excel 中达到了 1,048,576 行的限制，导致代码崩溃。

我想对其进行更新，以便在达到行数限制时，脚本开始将单元格复制到新工作表（例如“FinalFile2”、“FinalFile3”等），直到完全执行。

Sub KW()
'
' Exact KWs
'
Dim i, j, LastRow As Long
Dim relativePath As String

i = 2
j = 2

'LastRowValue'
Sheets("Output").Select
LastRow = Rows(Rows.Count).End(xlUp).Row - 1

'Clean final output'
  Sheets("FinalFile").Select
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select

'Set Variables in Variables sheet'

Do

'Var 1'
    Sheets("Names").Select
    Range("A" & i).Select
    Selection.Copy
    Sheets("Variables").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Var 2'
    Sheets("Names").Select
    Range("B" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

 'Var 3'
    Sheets("Names").Select
    Range("C" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

 'Var 4'
    Sheets("Names").Select
    Range("D" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


 'Var 5'
    Sheets("Names").Select
    Range("E" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("E2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


  'Var 6'
    Sheets("Names").Select
    Range("F" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("F2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

   'Var 7'
    Sheets("Names").Select
    Range("G" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("G2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


    'Var 8'
    Sheets("Names").Select
    Range("H" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("H2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False



     'Var 9'
    Sheets("Names").Select
    Range("I" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("I2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False



     'Var 10'
    Sheets("Names").Select
    Range("J" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("J2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False



     'Var 11'
    Sheets("Names").Select
    Range("K" & i).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Variables").Select
    Range("K2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False


'Copy and Paste'

    Sheets("Output").Select
    Range("A2:AP2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("FinalFile").Select
    Range("A" & j).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'update counters'

i = i + 1
j = j + LastRow

'end of loop condition'

Sheets("Names").Select

Loop Until IsEmpty(Cells(i, 1))



End Sub

【问题讨论】：

这要运行多长时间才能填满工作表？听起来您需要使用变量表并创建一个新表，j 达到 1,048,576 并重置 j。此外，您绝对应该删除选择 ***.com/questions/10714251/…

你也没有覆盖变量表中的值吗？全部粘贴到第 2 行。

我越看越困惑。您将"Names" 工作表的许多不同行复制到"Variables" 工作表的同一行，并将"Output" 工作表的同一行复制到"FinalFile" 一遍又一遍，总是跳过lastRow 行

【参考方案1】：

这里有一些提示如何改进您的代码。我不会讨论我在对原始问题的评论中提到的问题，而只是专注于代码的特定部分：

删除Selections。一般模式是代替

something.Select
Selection.Dosomenthing

你使用

something.Dosomething

在你的情况下：

Sheets("Names").Select
Range("A" & i).Select
Selection.Copy
Sheets("Variables").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

变成

Sheets("Names").Range("A" & i).Copy
Sheets("Variables").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

使用变量来引用您的工作表，如下所示：

Dim nameSheet as Worksheet
Dim varSheet as Worksheet
Dim finalSheet as Worksheet

Set nameSheet = Sheets("Names")
Set varSheet = Sheets("Variables")
Set finalSheet = Sheets("FinalFile")

现在你可以使用了

finalSheet.Range(...).Pastespecial ...

空间不足时使用Set finalSheet = Sheets("FinalFile2")

不要一个接一个地复制单元格。您将单元格 Ai 复制到 A2 然后将 Bi 复制到 B2。只需将Ai:Ki 范围复制到A2:K2 即可（虽然我不明白这一点）

如果不需要，请不要使用Copy。而不是

someRange.Copy
someOtherRange.PasteSpecial Paste:=xlPasteValues

你可以使用

someOtherRange.Value = someRange.Value

（确保大小相同）

在进行大量插入时，使用 Application.Screenupdating = False 禁用 Screenupdating（完成后将其设置为 True）。它可以大大加快宏的速度。

至于你的实际问题，按照汤姆的建议，添加

If j > 1048576 Then
    j = 2
    Set finalSheet = Sheets("FinalFile2") 'maybe create the new sheet at this point
End If

【参考方案2】：

你可以添加

j = j + lastRow
If j = 1048576 Then j = 2

但是你应该绝对清理这段代码。 .selections 是一种非常缓慢的方式来做这样的事情。查看this 并尽量避免.Copy 和.Paste。只需使用= 将目标单元格设置为源的值。这也节省了大量时间。

编辑：一定要看看@arcadeprecinct 发布的链接