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