Wie beschleunigt man diesen VBA-Code?

Question

Die Excel-Datei hat 9 Blätter. Jedes Blatt hat 1668 Zeilen und 34 Lieferanten. Ich möchte 1 Blatt erstellen, das alle Daten enthält. Ich weiß, dass es Duplikate geben wird, aber das ist jetzt egal. Gibt es eine Möglichkeit, den Code zu beschleunigen? Es dauert Ewigkeiten, um etwa 510.000 Datensätze zu kopieren. (Sie können die Kommentare mit meinem ersten Versuch sehen, wenn ich es mit for-Schleifen zu tun versucht, das war keine gute Idee.)

Sub goEasy() 

Dim wsText As Variant 
Dim sht As Worksheet 
Dim wSum As Worksheet 
Dim service As String 
Dim supplier As String 
Dim priceRange As String 
Dim price As String 
Dim Lrow As Long, LastRow As Long 
Dim a As Long, b As Long 

Set sht = ThisWorkbook.Worksheets(4) 
Set wSum = ThisWorkbook.Worksheets("Summary") 

wsText = Array("<25K", "25K <100K", "100K <250K", "250K <500K", "500K <1M", "1M <5M", "5M <15M", "15M <30M", "30M <50M") 

LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row 

For Each element In wsText 
    'For i = 5 To LastRow 
    a = 4 
    b = 12 

    Do While a < LastRow 
     'For j = 13 To 47 

     If a = LastRow Then 
      a = 4 
      Exit Do 
     End If 
     a = a + 1 

     Do While b <= 47 

      If b = 47 Then 
       b = 12 
       Exit Do 
      End If 

      b = b + 1 
      Lrow = wSum.UsedRange.Rows(wSum.UsedRange.Rows.Count).Row + 1 

      service = ThisWorkbook.Worksheets(element).Cells(a, 1).Text 
      supplier = ThisWorkbook.Worksheets(element).Cells(4, b).Text 
      priceRange = ThisWorkbook.Worksheets(element).Cells(2, 1).Text 
      price = ThisWorkbook.Worksheets(element).Cells(a, b).Text 

      wSum.Cells(Lrow, 1) = service 
      wSum.Cells(Lrow, 2) = supplier 
      wSum.Cells(Lrow, 3) = priceRange 
      wSum.Cells(Lrow, 4) = price 
      'Next j 
     Loop 

     'Next i 
    Loop 
Next element 


End Sub 

Answer 1

Dies sollte es tun:

Sub goEasy() 

Dim wsText As Variant 
Dim sht As Worksheet 
Dim wSum As Worksheet 
Dim service As String 
Dim supplier As String 
Dim priceRange As String 
Dim price As String 
Dim Lrow As Long, LastRow As Long 
Dim a As Long, b As Long 

Application.ScreenUpdating = False 

Set sht = ThisWorkbook.Worksheets(4) 
Set wSum = ThisWorkbook.Worksheets("Summary") 

wsText = Array("<25K", "25K <100K", "100K <250K", "250K <500K", "500K <1M", "1M <5M", "5M <15M", "15M <30M", "30M <50M") 

LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row 

    For Each element In wsText 
     'For i = 5 To LastRow 
     a = 4 
     b = 12 
     Do While a < LastRow 
      'For j = 13 To 47 

      If a = LastRow Then 
      a = 4 
      Exit Do 
      End If 
      a = a + 1 

      Do While b <= 47 

      If b = 47 Then 
      b = 12 
      Exit Do 
      End If 

       b = b + 1 
       Lrow = wSum.UsedRange.Rows(wSum.UsedRange.Rows.Count).Row + 1 

       service = ThisWorkbook.Worksheets(element).Cells(a, 1).Text 
       supplier = ThisWorkbook.Worksheets(element).Cells(4, b).Text 
       priceRange = ThisWorkbook.Worksheets(element).Cells(2, 1).Text 
       price = ThisWorkbook.Worksheets(element).Cells(a, b).Text 

       wSum.Cells(Lrow, 1) = service 
       wSum.Cells(Lrow, 2) = supplier 
       wSum.Cells(Lrow, 3) = priceRange 
       wSum.Cells(Lrow, 4) = price 
      'Next j 
      Loop 
     'Next i 
     Loop 
    Next element 

Application.ScreenUpdating = True 

End Sub 

Answer 2

Bitte Probieren Sie den folgenden Code aus. (nicht getestet)
Es braucht Zeit, um Wert in eine Zelle zu schreiben. Wenn Sie Werte in Zellen schreiben, wird Ihr VBA langsam.
Nach Array schreiben Sie nur einmal in Zellen. Es wird viel Zeit sparen.

Sub goEasy() 
    dim a as long, b as long, LastRow as long 
    dim sht as worksheet, wSum as worksheet 
    dim wsText as variant, element as variant, dAry as variant 

    set sht = thisworkbook.worksheets(4) 
    set wSum = Thisworkbook.worksheets("summary") 
    wsText = Array("<25K", "25K <100K", "100K <250K", "250K <500K", "500K <1M", "1M <5M", "5M <15M", "15M <30M", "30M <50M") 

    LastRow = sht.Cells(Rows.Count, 1).End(xlUp).Row 
    For Each element In wsText 
     a = 5 
     b = 13 
     Do until a > LastRow 'For i = 5 To LastRow 
      Do until b > 47 'For j = 13 To 47 
       if not isarray(dAry) then 
        redim dAry(3, 0) as variant 
       else 
        redim preserve dAry(3, ubound(dAry, 2) + 1) as variant 
       end if 

       With thisworkbook.Worksheets(element) 
        dAry(0, ubound(dAry,2)) = .Cells(a, 1).Text 
        dAry(1, ubound(dAry,2)) = .Cells(4, b).Text 
        dAry(2, ubound(dAry,2)) = .Cells(2, 1).Text 
        dAry(3, ubound(dAry,2)) = .Cells(a, b).Text 
       End With 
       b = b + 1 'Next j 
      Loop 
      b = 13 
      a = a + 1 'Next i 
     Loop 
    Next element 
    wSum.Cells(rows.count, 1).end(xlup).offset(1).resize(ubound(dAry,2) + 1, ubound(dAry,1) + 1) = application.transpose(dAry) 
End Sub