Копирование большого количества данных в VBA excel

Question

Я хотел был бы скопировать около 30k строк (точнее, только некоторые элементы строк) из листа A в лист B, начиная назначение из строки № 36155. Иногда , мы копируем строку более одного раза, в зависимости от числа в столбце G. Это макрос, который я написал:

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 

К сожалению, для этого макроса требуется много времени (около 10 минут). У меня такое чувство, что может быть лучший способ сделать это. У вас есть идеи, как мы можем зачаровать макрос?

Answer 1

Попробуйте использовать варианты массивов: может быть даже быстрее, если вы можете использовать массив B, содержащий более 1 строки. Эта версия занимает 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

Я предлагаю вам прочитать ваши данные в наборе записей as shown here, а затем закодировать набор записей.

Попробуйте следующее (непроверено).

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 

Примечание: - использование записей дает вам дополнительные возможности, такие как фильтрация данных - с, ваше записей не зависит от колонны порядка ваших входных-данных, то есть вы не должны отрегулируйте свой макрос, если вы решите добавить еще один столбец на лист A (при условии, что заголовки не совпадают)

Надеюсь, это поможет.