Excel VBA running very slow looping

Question

I have a small supplier price list which is effective data from x to y dates (in rows) with number of same products (in columns - quite a few). I am trying to copy the rows into another sheet but this time at a date level instead of range x/y that I need to export into a csv. Only limitation I have that I cannot change the format of price list.

The vba code is working but its very slow although only I have a price list of 150 rows (sheet 1) that will translate into 6000 rows (in test), its taking hours to run the code. Could you advise how I could improve the performance? My vba skills are very basic and I have cobbled this together from other people code.

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

Have you gone through [this question](http://stackoverflow.com/questions/20738373/can-i-make-this-macro-more-efficient-or-faster) on making macros faster? — Techie, Dec 28 '16 at 13:31
You fill cell by cell, why not by block of cells? `Range("A" & TargetRow & ":E" & TargetRow).Value = Range("A" & SourceRow & ":E" & SourceRow).Value` and From G to AH. And you dont need to convert your rows to strings. — CommonSense, Dec 28 '16 at 14:06

score 0 · Accepted Answer · answered Dec 28 '16 at 14:04

Difficult to run this code as you have not supplied test data but please pay attention to the code marked as #COPY THE BLOCK where you will find the magic line rngDest.Value2 = rngSrc.Value2 which will definitely speed up you code.

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

score 0 · Answer 2 · answered Dec 28 '16 at 16:04

Loading the data into an array, putting the results in another array, and then outputting the results to the sheet only once at the very end is always the fastest method:

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

Thank you very much - trying out people suggestion. When I tried the code out, I am getting subscript out of range error on the following line. (aResults(lResultIndex, k) = aData(i, k)) — riq sid, Dec 28 '16 at 18:26
@riqsid Then your data is not sorted, or it isn't laid out as described. Please provide sample data — tigeravatar, Dec 28 '16 at 18:27

Excel VBA running very slow looping

2 Answers2