在VBA excel中复制大量的数据

我希望能够从表单A复制大约30k行（确切地说，只是行中的一些元素）到表单B，从行36155行开始目的地。有时，我们复制行不止一次，具体取决于G列中的数字。 这是我写的macros：

Sub copy() ActiveSheet.DisplayPageBreaks = False Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculate Dim k As Long, k1 As Long, i As Integer k = 36155 k1 = 30000 For i = 1 To k1 For j = 1 To Sheets("A").Range("G" & i + 2).Value Sheets("B").Range("A" & k).Value = Sheets("A").Range("A" & i + 2).Value Sheets("B").Range("B" & k).Value = Sheets("A").Range("B" & i + 2).Value Sheets("B").Range("C" & k).Value = j Sheets("B").Range("D" & k).Value = Sheets("A").Range("C" & i + 2).Value Sheets("B").Range("E" & k).Value = Sheets("A").Range("D" & i + 2).Value Sheets("B").Range("F" & k).Value = Sheets("A").Range("E" & i + 2).Value Sheets("B").Range("G" & k).Value = Sheets("A").Range("F" & i + 2).Value Sheets("B").Range("H" & k).Value = Sheets("A").Range("I" & i + 2).Value + (j - 1) * Sheets("A").Range("H" & i + 2).Value Sheets("B").Range("I" & k).Value = Sheets("A").Range("J" & i + 2).Value k = k + 1 Next j Next i Application.EnableEvents = True Application.CutCopyMode = False Application.ScreenUpdating = True End Sub 

不幸的是，这个macros需要花费很多时间（大约10分钟）。 我有一种感觉，可能有更好的办法做到这一点..你有什么想法，我们如何能够增加macros观？

Answer 1

尝试使用变体数组：如果您可以使用包含多于一行的B数组，可能会更快。 这个版本在我的电脑上需要17秒。

 Sub Copy2() ActiveSheet.DisplayPageBreaks = False Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculate ' Dim k As Long, k1 As Long, i As Long, j As Long Dim varAdata As Variant Dim varBdata() As Variant ' Dim dT As Double ' dT = Now() ' k = 36155 k1 = 30000 ' ' get sheet A data into variant array ' varAdata = Worksheets("A").Range("A1:J1").Resize(k1 + 2).Value2 ' For i = 1 To k1 'For j = 1 To Sheets("A").Range("G" & i + 2).Value For j = 1 To varAdata(i + 2, 7) ' ' create empty row of data for sheet B and fill from variant array of A data ' ReDim varBdata(1 to 1,1 to 9) As Variant 'Sheets("B").Range("A" & k).Value = Sheets("A").Range("A" & i + 2).Value varBdata(1, 1) = varAdata(i + 2, 1) varBdata(1, 2) = varAdata(i + 2, 2) varBdata(1, 3) = j varBdata(1, 4) = varAdata(i + 2, 3) varBdata(1, 5) = varAdata(i + 2, 4) varBdata(1, 6) = varAdata(i + 2, 5) varBdata(1, 7) = varAdata(i + 2, 6) varBdata(1, 8) = varAdata(i + 2, 9) + (j - 1) * varAdata(i + 2, 8) varBdata(1, 9) = varAdata(i + 2, 10) ' ' write to sheet B ' Sheets("B").Range("A1:I1").Offset(k - 1).Value2 = varBdata k = k + 1 Next j Next i ' Application.EnableEvents = True Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox (Now() - dT) End Sub 

Answer 2

我build议你将数据读入logging集，如下所示 ，然后循环logging集。

尝试以下（未经testing）。

 Sub copy() With Application .ScreenUpdating = False .EnableEvents = False .Calculate .Calculation = xlCalculationManual End With Dim k As Long, i As Integer k = 36155 ' read data into a recordset Dim rst As Object Set rst = GetRecordset(ThisWorkbook.Sheets("A").UsedRange) 'feel free to hard-code your range here With rst While Not .EOF For j = 1 To !FieldG ' !FieldG accesses the Datafield with the header "FieldG". Change this to the header you actually got in Column G, like "!MyColumnG" or ![columnG with blanks] Sheets("B").Cells(k, 1).Value = !FieldA ' ... your code k = k + 1 Next j .movenext Wend End With With Application .EnableEvents = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub 

另外将下面的函数添加到您的VBA模块中。

 Function GetRecordset(rng As Range) As Object 'Recordset ohne Connection: 'https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/ Dim xlXML As Object Dim rst As Object Set rst = CreateObject("ADODB.Recordset") Set xlXML = CreateObject("MSXML2.DOMDocument") xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML) rst.Open xlXML Set GetRecordset = rst End Function 

注意： – 使用logging集可以为您提供其他选项，例如过滤数据 – 使用logging集，而不依赖于input数据的列顺序，这意味着如果您决定添加另一列，则无需调整macros表A（只要你保持头相同）

希望这可以帮助。