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

Answer 1

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

Answer 2

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