VBA에서 대용량 데이터 복사하기

Question

행 A에서 시트 B까지 약 30k 행 (정확하게는 행의 일부 요소)을 복사하고 행 번호 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 배열을 사용할 수있는 경우 더욱 빨라질 수 있습니다. 이 버전은 내 PC에서 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에 다른 열을 추가하려는 경우 매크로를 조정하십시오 (헤더를 동일하게 유지하는 한)

희망이 있습니다.