Excel VBA运行非常慢的循环

Question

我有一个小的供应商价格表，其中包含从x到y日期（行）的有效数据，其中包含相同产品的数量（以列为单位）。 我正在尝试将行复制到另一个工作表中，但这一次是在日期级别，而不是我需要导出到csv的范围x / y。 唯一的限制是我无法更改价目表的格式。

vba代码可以正常工作，但是速度很慢，尽管只有我列出了150行的价格表（第1页），这将转化为6000行（测试中），运行代码需要花费数小时。 您能建议我如何改善效果吗？ 我的vba技能非常基础，我已经从其他人的代码中吸取了这些技巧。

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

由于您没有提供测试数据，因此难以运行此代码，但请注意标记为#COPY THE BLOCK的代码，在该代码中您会找到神奇的行rngDest.Value2 = rngSrc.Value2 ，这肯定会加快您的代码速度。

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