Excel VBAは非常に遅いループを実行しています

Question

私は同じ製品の数（列数 - かなりの数）を持つxからyの日付（行）の有効データである小さなサプライヤの価格表を持っています。私は行を別のシートにコピーしようとしていますが、今回はcsvにエクスポートする必要がある範囲x/yの代わりに日付レベルでこの時間をコピーしようとしています。私が価格リストのフォーマットを変更することはできないという制限があるだけです。

vbaコードは動作していますが、コードが実行されるまでに6000行（テスト中）に翻訳される150行（シート1）の料金表がありますが、非常に遅いです。どのようにパフォーマンスを改善できるかアドバイスできますか？私のVBAのスキルは非常に基本的なものであり、私は他の人のコードから一緒にこれを石畳みました。あなたは、テストデータを供給していますが、間違いなくあなたのコードをスピードアップします魔法のラインrngDest.Value2 = rngSrc.Value2を見つけるでしょう#COPY THE BLOCKとしてマークされたコードに注意してくださいしていないとして、このコードを実行することが困難

Sub ExpandData() 

Dim SourceRow, TargetRow As Long 
Dim LastDate, NextDate As Date 
Dim DateDiff, FillDate As Integer 
SourceRow = 4 
TargetRow = 4 

'Loop through source rows 
Do While Worksheets("Sheet1").Range("C" & CStr(SourceRow)).Value <> "" 
    LastDate = Worksheets("Sheet1").Range("F" & CStr(SourceRow)).Value 
    ' Check for the last row of data and use todays date if last row 
    If Worksheets("Sheet1").Range("F" & CStr(SourceRow + 1)).Value <> "" Then 
     NextDate = Worksheets("Sheet1").Range("F" & CStr(SourceRow + 1)).Value 
    Else 
     NextDate = Date 
    End If 
    DateDiff = NextDate - LastDate 
    ' create a row in the target sheet for each date in between those in the source sheet 
    For FillDate = 0 To DateDiff - 1 
     Worksheets("test").Range("A" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("A" & CStr(SourceRow)).Value 
     Worksheets("test").Range("B" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("B" & CStr(SourceRow)).Value 
     Worksheets("test").Range("C" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("C" & CStr(SourceRow)).Value 
     Worksheets("test").Range("D" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("D" & CStr(SourceRow)).Value 
     Worksheets("test").Range("E" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("E" & CStr(SourceRow)).Value 
     Worksheets("test").Range("F" & CStr(TargetRow)).Value = LastDate + FillDate 
     Worksheets("test").Range("G" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("G" & CStr(SourceRow)).Value 
     Worksheets("test").Range("H" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("H" & CStr(SourceRow)).Value 
     Worksheets("test").Range("I" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("I" & CStr(SourceRow)).Value 
     Worksheets("test").Range("J" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("J" & CStr(SourceRow)).Value 
     Worksheets("test").Range("K" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("K" & CStr(SourceRow)).Value 
     Worksheets("test").Range("L" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("L" & CStr(SourceRow)).Value 
     Worksheets("test").Range("M" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("M" & CStr(SourceRow)).Value 
     Worksheets("test").Range("N" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("N" & CStr(SourceRow)).Value 
     Worksheets("test").Range("O" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("O" & CStr(SourceRow)).Value 
     Worksheets("test").Range("P" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("P" & CStr(SourceRow)).Value 
     Worksheets("test").Range("Q" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("Q" & CStr(SourceRow)).Value 
     Worksheets("test").Range("R" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("R" & CStr(SourceRow)).Value 
     Worksheets("test").Range("S" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("S" & CStr(SourceRow)).Value 
     Worksheets("test").Range("T" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("T" & CStr(SourceRow)).Value 
     Worksheets("test").Range("U" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("U" & CStr(SourceRow)).Value 
     Worksheets("test").Range("V" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("V" & CStr(SourceRow)).Value 
     Worksheets("test").Range("W" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("W" & CStr(SourceRow)).Value 
     Worksheets("test").Range("X" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("X" & CStr(SourceRow)).Value 
     Worksheets("test").Range("Y" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("Y" & CStr(SourceRow)).Value 
     Worksheets("test").Range("Z" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("Z" & CStr(SourceRow)).Value 
     Worksheets("test").Range("AA" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("AA" & CStr(SourceRow)).Value 
     Worksheets("test").Range("AB" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("AB" & CStr(SourceRow)).Value 
     Worksheets("test").Range("AC" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("AC" & CStr(SourceRow)).Value 
     Worksheets("test").Range("AD" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("AD" & CStr(SourceRow)).Value 
     Worksheets("test").Range("AE" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("AE" & CStr(SourceRow)).Value 
     Worksheets("test").Range("AF" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("AF" & CStr(SourceRow)).Value 
     Worksheets("test").Range("AG" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("AG" & CStr(SourceRow)).Value 
     Worksheets("test").Range("AH" & CStr(TargetRow)).Value = Worksheets("Sheet1").Range("AH" & CStr(SourceRow)).Value 
     TargetRow = TargetRow + 1 
    Next FillDate 

    SourceRow = SourceRow + 1 
Loop 

End Sub 

Answer 1

。別の配列に結果を入れて、配列にデータをロードした後、一番最後に一度だけシートに結果を出力することは、常に最速の方法です

Option Explicit 

Sub ExpandData() 

    Dim SourceRow, TargetRow As Long 
    Dim LastDate, NextDate As Date 
    Dim DateDiff, FillDate As Integer 
    SourceRow = 4 
    TargetRow = 4 

    '* COPY THE BLOCK 
    Dim wsSheet1 As Excel.Worksheet, wsTest As Excel.Worksheet 
    Set wsSheet1 = Worksheets("Sheet1") 
    Set wsTest = Worksheets("test") 

    Dim rngSrc As Excel.Range 
    Set rngSrc = wsSheet1.Range(wsSheet1.Cells(1, TargetRow), wsSheet1.Cells(1, TargetRow + DateDiff - 1)) 

    Dim rngDest As Excel.Range 
    Set rngDest = wsTest.Range(wsTest.Cells(1, SourceRow), wsTest.Cells(1, SourceRow + DateDiff - 1)) 

    rngDest.Value2 = rngSrc.Value2 
    '* END OF COPY THE BLOCK 


    'Loop through source rows 
    Do While Worksheets("Sheet1").Range("C" & CStr(SourceRow)).Value <> "" 
     LastDate = Worksheets("Sheet1").Range("F" & CStr(SourceRow)).Value 
     ' Check for the last row of data and use todays date if last row 
     If Worksheets("Sheet1").Range("F" & CStr(SourceRow + 1)).Value <> "" Then 
      NextDate = Worksheets("Sheet1").Range("F" & CStr(SourceRow + 1)).Value 
     Else 
      NextDate = Date 
     End If 
     DateDiff = NextDate - LastDate 
     ' create a row in the target sheet for each date in between those in the source sheet 

     '* optimization of F column left as an exercise 
     For FillDate = 0 To DateDiff - 1 
      Worksheets("test").Range("F" & CStr(TargetRow)).Value = LastDate + FillDate 
      TargetRow = TargetRow + 1 
     Next FillDate 

     SourceRow = SourceRow + 1 
    Loop 

End Sub 

Answer 2

：

Sub tgr() 

    Dim wb As Workbook 
    Dim wsData As Worksheet 
    Dim wsDest As Worksheet 
    Dim aData As Variant 
    Dim aResults() As Variant 
    Dim i As Long, j As Long, k As Long 
    Dim lResultIndex As Long 
    Dim dtNext As Date 
    Dim sDateFormat As String 

    Const lDateCol As Long = 6   'Column F 
    Const sStartCol As String = "A" 
    Const sFinalCol As String = "AH" 
    Const lStartRow As Long = 4 

    Set wb = ActiveWorkbook 
    Set wsData = wb.Sheets("Sheet1") 
    Set wsDest = wb.Sheets("test") 

    With wsData.Range(sStartCol & lStartRow & ":" & sFinalCol & wsData.Cells(wsData.Rows.Count, "C").End(xlUp).Row) 
     If .Row < 4 Then Exit Sub 'No data 
     aData = .Value 'Load the source data into an array 
    End With 

    'Prepare the results array 
    ReDim aResults(1 To Date - aData(1, lDateCol) + 1, 1 To UBound(aData, 2)) 

    'Loop through the data array 
    For i = 1 To UBound(aData, 1) 
     'Define the next date 
     If i = UBound(aData, 1) Then dtNext = Date Else dtNext = Int(aData(i + 1, lDateCol)) - 1 

     'For each date, add a line to the results array 
     For j = aData(i, lDateCol) To dtNext 
      lResultIndex = lResultIndex + 1 
      For k = 1 To UBound(aData, 2) 
       If k = lDateCol Then 
        aResults(lResultIndex, k) = j 
       Else 
        aResults(lResultIndex, k) = aData(i, k) 
       End If 
      Next k 
     Next j 
    Next i 

    'If there is existing data where the results would go, you'll need to clear that first 
    'To clear any existing data (if necessary) uncomment the following line: 
    'wsDest.Range(sStartCol & lStartRow & ":" & sFinalCol & wsDest.Rows.Count).Clear 

    'Output the results array 
    wsDest.Range(sStartCol & lStartRow).Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults 

End Sub