Excel VBA inefficient For loop

Question

I have data that is output into 4 channels, one channel a second (channel 1 = 1st second, channel 2 = 2nd second, etc). So there are 4 columns for time and 4 for the associated data, which outputs into excel format.

I have created a simple for loop to collate the 4 columns of data into one, for each parameter. There are 124 parameters, and 5000 - 15000 data points long.

My current for loop is taking about 16 seconds per loop, which means it will take about 33 minutes per run to collate the data. I am no expert with coding or VBA by any stretch, so please forgive the bad format, etc.. just wondering if anyone here may have suggestions for improving the speed of this for loop. The slowest part seems to be the 'i' for loop, removing the 'k' for loop it is still 16 seconds or more.

The code is below:

Sub Create_CombinedData()
    '
    ' Create_CombinedData Macro
    '

    Sheets("Sheet2").Select
    graphrange = Application.WorksheetFunction.CountA(ActiveSheet.Columns(1))

    j = 0
    m = 497
    n = 498
    o = 0

    For k = 1 To 124
        For i = 2 To graphrange
            Cells(i + j, m).Value = Cells(2 * i - 2, o + 249).Value
            Cells(i + j, n).Value = Cells(2 * i - 2, o + 250).Value
            Cells(1 + i + j, m).Value = Cells(2 * i - 2, o + 373).Value
            Cells(1 + i + j, n).Value = Cells(2 * i - 2, o + 374).Value
            Cells(2 + i + j, m).Value = Cells(2 * i - 2, o + 1).Value
            Cells(2 + i + j, n).Value = Cells(2 * i - 2, o + 2).Value
            Cells(3 + i + j, m).Value = Cells(2 * i - 2, o + 125).Value
            Cells(3 + i + j, n).Value = Cells(2 * i - 2, o + 126).Value
            j = j + 3
        Next i
        m = m + 2
        n = n + 2
        o = o + 2
        l = 2
        j = 0
    Next k
End Sub

start your macro with application.screenupdating=false, finish it with application.screenupdating=true and see if that makes it fast enough for you — nutsch
– nutsch, Commented Apr 20, 2018 at 17:46
@Jeeped k also seems to be useless, besides iterating through the 4 variables (which one of which could just be k). — dwirony
– dwirony, Commented Apr 20, 2018 at 19:55
Sorry for the extra variables - forgot to take those out from previous attempts at speeding it up. I tried the screenupdating suggestion, there is a small improvement in speed. Thanks — sweet_bro99
– sweet_bro99, Commented Apr 23, 2018 at 15:24

sweet_bro99 · Accepted Answer · 2018-05-28 12:22:41Z

Thanks to Paul Bica, here is the final code that works.

I had to play around with the array, split it into input and output data. "arr" loads the data that is to be combined, and "arr 2" is where that combined data is outputted. The whole process is split in two, top half of data and bottom half of data - otherwise, I was running out of memory.

I couldn't quite figure out the last row / last column bit to make it work, so I brute forced it with different numbers until it worked. I am sure there is a more logical way, but it does what it needs to do for my application.

Hope that helps.

Public Sub CreateCombinedData2()
    Dim ws As Worksheet, lr As Long, lc As Long, col1 As Long, col2 As Long
    Dim rId As Long, cr As Long, rr As Long, fr As Long, arr As Variant, arr2 As Variant, k As Long
    Dim half As Long, fCol As Long
    arr = Empty
    arr2 = Emtpy
    Sheets("Sheet3").Cells.ClearContents
    Set ws = ThisWorkbook.Worksheets("Sheet2")  

On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Sheet1").ChartObjects.Delete   'this clears previous plots
Application.DisplayAlerts = True
On Error GoTo 0

lr = Application.WorksheetFunction.CountA(ws.Columns(1)) * 2  'last row
lc = Application.WorksheetFunction.CountA(ws.Rows(2)) + 300   'last col
half = lr \ 2

col1 = 497: col2 = 498
arr = ws.Range(ws.Cells(2, 1), ws.Cells(half, lc))          'Top half rows
arr2 = ws.Range(ws.Cells(2, lc), ws.Cells(half, lc * 2))
For k = 1 To 62
Sheets("Sheet3").Select
Cells(1, col1).Value = ws.Cells(1, fCol + 2)
    For cr = 2 To half * 0.25
        rr = cr + rId
        fr = 2 * cr - 2
        arr2(rr + 0, col1) = arr(fr, fCol + 1): arr2(rr + 0, col2) = arr(fr, fCol + 2)
        arr2(rr + 1, col1) = arr(fr, fCol + 125): arr2(rr + 1, col2) = arr(fr, fCol + 126)
        arr2(rr + 2, col1) = arr(fr, fCol + 249): arr2(rr + 2, col2) = arr(fr, fCol + 250)
        arr2(rr + 3, col1) = arr(fr, fCol + 373): arr2(rr + 3, col2) = arr(fr, fCol + 374)
        rId = rId + 3
    Next cr
  col1 = col1 + 2:    col2 = col2 + 2
  fCol = fCol + 2
  rId = 0
Next k
Sheets("Sheet3").Select
Range(Cells(2, 1), Cells(half, lc)) = arr2

col1 = 497
col2 = 498
rId = 0
fCol = 0
rr = 0
fr = 0
arr = Empty
arr2 = Emtpy

arr = ws.Range(ws.Cells(2, 1), ws.Cells(half, lc))     'Bottom half rows
arr2 = ws.Range(ws.Cells(2, lc), ws.Cells(lr, lc * 2))
For k = 1 To 62

    For cr = half * 0.25 To half * 0.5
        rr = cr + rId - half * 0.25 + 1
        fr = 2 * cr - 2
        arr2(rr + 0, col1) = arr(fr, fCol + 1): arr2(rr + 0, col2) = arr(fr, fCol + 2)
        arr2(rr + 1, col1) = arr(fr, fCol + 125): arr2(rr + 1, col2) = arr(fr, fCol + 126)
        arr2(rr + 2, col1) = arr(fr, fCol + 249): arr2(rr + 2, col2) = arr(fr, fCol + 250)
        arr2(rr + 3, col1) = arr(fr, fCol + 373): arr2(rr + 3, col2) = arr(fr, fCol + 374)
        rId = rId + 3
     Next cr
  col1 = col1 + 2:    col2 = col2 + 2
  fCol = fCol + 2
  rId = 0
   Next k


   Sheets("Sheet3").Select
   Range(Cells(half + 1, 1), Cells(lr, lc)) = arr2



Wend

End Sub

paul bica · Accepted Answer · 2018-04-25 19:27:39Z

0

Code below is the initial Sub converted to use an array (untested). It assumes all data is on Sheet2

I'm not sure is if the last column is determined properly:

Currently it extracts last col based on the last used cell in row 2 (you may need to adjust it)

.

Option Explicit

Public Sub CreateCombinedData1()
    Dim ws As Worksheet, lr As Long, lc As Long, col1 As Long, col2 As Long
    Dim rId As Long, cr As Long, rr As Long, fr As Long, arr As Variant, k As Long
    Dim half As Long, fCol As Long

    Set ws = ThisWorkbook.Worksheets("Sheet2")                  'or ActiveSheet

    lr = Application.WorksheetFunction.CountA(ws.Columns(1))    'last row
    lc = Application.WorksheetFunction.CountA(ws.Rows(2))       'last col
    half = lr \ 2

    col1 = 497
    col2 = 498
    arr = ws.Range(ws.Cells(2, 1), ws.Cells(half, lc))          'Top half rows
    For k = 1 To 124
      For cr = 2 To half
       rr = cr + rId
       fr = 2 * cr - 2
       arr(rr + 0, col1) = arr(fr, fCol + 249): arr(rr + 0, col2) = arr(fr, fCol + 250)
       arr(rr + 1, col1) = arr(fr, fCol + 373): arr(rr + 1, col2) = arr(fr, fCol + 374)
       arr(rr + 2, col1) = arr(fr, fCol + 1):   arr(rr + 2, col2) = arr(fr, fCol + 2)
       arr(rr + 3, col1) = arr(fr, fCol + 125): arr(rr + 3, col2) = arr(fr, fCol + 126)
       rId = rId + 3
      Next cr
      col1 = col1 + 2
      col2 = col2 + 2
      fCol = fCol + 2
      rId = 0
    Next k
    ws.Range(ws.Cells(2, 1), ws.Cells(half, lc)) = arr

    col1 = 497
    col2 = 498
    rId = 0
    fCol = 0
    rr = 0
    fr = 0
    arr = Empty
    arr = ws.Range(ws.Cells(half + 1, 1), ws.Cells(lr, lc))     'Bottom half rows
    For k = 1 To 124
      For cr = half + 1 To lr
       rr = cr + rId
       fr = 2 * cr - 2
       arr(rr + 0, col1) = arr(fr, fCol + 249): arr(rr + 0, col2) = arr(fr, fCol + 250)
       arr(rr + 1, col1) = arr(fr, fCol + 373): arr(rr + 1, col2) = arr(fr, fCol + 374)
       arr(rr + 2, col1) = arr(fr, fCol + 1):   arr(rr + 2, col2) = arr(fr, fCol + 2)
       arr(rr + 3, col1) = arr(fr, fCol + 125): arr(rr + 3, col2) = arr(fr, fCol + 126)
       rId = rId + 3
      Next cr
      col1 = col1 + 2
      col2 = col2 + 2
      fCol = fCol + 2
      rId = 0
    Next k
    ws.Range(ws.Cells(half + 1, 1), ws.Cells(lr, lc)) = arr
End Sub

edited Apr 25, 2018 at 19:27

answered Apr 20, 2018 at 21:14

paul bica

10.8k4 gold badges27 silver badges45 bronze badges

7 Comments

sweet_bro99 Over a year ago

Hi Paul, Thanks for the help. I keep getting "Subscript out of range" for the arrays on the left of the equal signs (arr(rr+0,col1) for example) Not too sure what that means. Googling the error does not lead to many answers. Cheers

paul bica Over a year ago

It means that the array is not setup properly - last row or last column are incorrect. I can't check the used range of your sheet but you can "see" how the array is setup with this statement: ws.Range(ws.Cells(2, 1), ws.Cells(lr, lc)).Select - this will select the entire UsedRange. If it doesn't look OK, check the values of lr and lc. Step through the code line by line using F8. Once you fix it it will be a lot faster than before

sweet_bro99 Over a year ago

Ah, ok - got it working. Now I am getting an 'out of memory' error. It gets through the loop fine, but the "ws.Range(ws.Cells(2, 1), ws.Cells(lr, lc)) = arr" line it runs out of memory. Any thoughts? Any way to break up that array output perhaps?

sweet_bro99 Over a year ago

for a file that is too large, lr is 23204, and lc is 620. The actual input data is 5801 rows long, but as it is 4 columns being blended together, it is 4 times that length. Because of this, I added *4 to the lr value and +152 (not sure why it isn't 124, but 152 is the smallest # that will work) to the lc value. I also slightly modified the loop, using -3, -2, -1 instead of +1, +2, +3, and adjusted cr=4 to accommodate.

paul bica Over a year ago

I divided the rows in 2 half's - 1st main loop going from row 2 to lastRow \ 2, the 2nd going from lastRow \ 2 to last row

|

Collectives™ on Stack Overflow

Excel VBA inefficient For loop

2 Answers 2

Comments

7 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Comments

7 Comments

Your Answer

Sign up or log in

Post as a guest

Related