Excel VBA運行速度非常慢循環

我有一個小的供應商價格表，它是從x到y日期（行中）有相同產品數量的有效數據（在列中 - 很多）。我試圖複製行到另一個工作表，但這次是在日期級別而不是範圍x/y，我需要導出到csv。我只有限制我不能改變價目表的格式。Excel VBA運行速度非常慢循環

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

來源

2016-12-28 riq sid

都去了哪裏通過[這個問題]（http://stackoverflow.com/questions/20738373/can-i-make-this-macro-more-efficient-or-faster）使宏更快？ – Spidey

您可以按細胞填充細胞，爲什麼不通過細胞塊？範圍（「A」＆TargetRow＆「：E」＆TargetRow）.Value =範圍（「A」＆SourceRow＆「：E」＆SourceRow）.Value'並從G到AH。而且你不需要將你的行轉換爲字符串。 – CommonSense

謝謝您使用了以上部分其他VB –

很難運行，你沒有提供的測試數據，但請注意標記爲#COPY塊中的代碼，你會發現魔線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

來源

2016-12-28 14:04:07

的數據加載到一個數組，把結果在另一個數組，然後在最後結果輸出到紙張只有一次永遠是最快的方法：

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

來源

2016-12-28 16:04:46 tigeravatar

非常感謝 - 嘗試人們的建議。當我將代碼嘗試出來時，我在下面一行中得到下標超出範圍錯誤。（aResults（lResultIndex，k）= aData（i，k）） –

@riqsid然後你的數據沒有排序，或者它沒有按照描述的佈局。請提供樣本數據 – tigeravatar

Excel VBA運行速度非常慢循環

回答

相關問題