このVBAコードをスピードアップするには？

Question

Excelファイルには9枚あります。各シートには1668行と34のサプライヤがあります。すべてのデータを含む1枚のシートを作成したいと思います。私は重複があるこの方法を知っているが、それは今は問題ではない。コードをスピードアップする方法はありますか？およそ510,000レコードをコピーするには永遠の時間がかかります。 （あなたは私がforループでそれを実行しようとしました私の最初の試みとのコメントを参照することができ、それは良いアイデアではありませんでした。）

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

これはそれを行う必要があります。

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

してください次のコードを試してください。 （テストされていません）
セルに値を書き込むのに時間がかかります。値をセルに書き込むと、VBAが遅くなります。
配列では、セルに一度だけ書き込みます。それは多くの時間を節約します。

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