Copying big amount of data in 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?


Show source
| excel-vba   | vba   | excel   | performance   2017-01-02 11:01 2 Answers

Answers to Copying big amount of data in VBA excel ( 2 )

  1. 2017-01-02 12:01

    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.

  2. 2017-01-02 16:01

    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
    

Leave a reply to - Copying big amount of data in VBA excel

◀ Go back