在VBA Excel中复制大量数据

Question

I would like to be able to copy around 30k rows (to be exact, just some elements of the rows) from sheet A to sheet B, starting the destination from row nr 36155. Sometimes, we copy the row more than once, depending on the number in the G column. This is the macro I've written:

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

Unfortunately, this macro takes a lot of time to run (around 10 minutes). I have a feeling that, there may be a better way to do that.. Do you have any ideas, how can we enchance the macro?

Answer 1

I would suggest you read your data into a recordset as shown here , then loop the recordset.

Try the following (untested).

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

Also add the following Function into your VBA Module.

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

Note: - using a recordset gives you additional options like filtering data - with a recordset, your not dependent on the column-order of your input-data, meaning you don't have to adjust your macro if you decide to add another column to sheet A (as long as you keep the headers the same)

Hope this helps.

Answer 2

Try this using variant arrays: could be even faster if you can use a B array containing more than 1 row. This version takes 17 seconds on my PC.

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