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

所以我在VBA中写了一个相当简单的macros，它更新了一组variables，然后将更新的值复制并粘贴到新的表格中。 问题是现在音量变得有些压倒性，因此在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 

Answer 1

这里有一些提示如何改善你的代码。 我不是在我对原始问题的评论中提到的问题，而只是集中在代码的特定部分：

1. 删除Selection 一般的模式是，而不是

    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 

2. 使用variables来引用你的工作表，像这样：

    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")使用Set finalSheet = Sheets("FinalFile2")

3. 不要一个接一个复制单元格。 您将单元格Ai复制到A2然后将Bi复制到B2 。 只需将范围Ai:Ki复制到A2:K2 （尽pipe我没有看到这一点）

4. 如果你不需要，不要使用Copy 。 代替

    someRange.Copy someOtherRange.PasteSpecial Paste:=xlPasteValues 

   您可以使用

    someOtherRange.Value = someRange.Value 

   （确保尺寸相同）

5. 使用Application.Screenupdating = False禁用Screenupdating （在完成后将其设置为True ），当您执行大量插入时。 它可以加速macros观很多。

6. 至于你真正的问题，像汤姆build议的那样，加上

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

Answer 2

你可以加

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

但是你应该清理这个代码。 .selections是一个非常缓慢的方式来做这样的事情。 看看这个，并尽量避免.Copy ＆ .Copy 。 只需将您的目标单元格设置为您的源代码的值即可。 这也节省了很多时间。

编辑：绝对看看@arcadeprecinct张贴的链接