Loop through a large data set efficiently.

[blacksmoke]

Hello,

I am using the code to loop through a large table of data (~170000 lines). It is verrrry slow. About a minute per 1000 lines. How can I speed things up?

Thanks,
Chris

Sub Fixtable()
Dim lo As Excel.ListObject
Dim loRow As Excel.ListRow
Dim oldRow As Long
Dim newRow As Long
Dim i As Long
Dim j As Integer
Dim k As Integer
Application.ScreenUpdating = False
Dim rowCount As Long
Set lo = Worksheets("Raw Data").ListObjects("Table_ExternalData_1")
With lo
  ' Make type column in position 6
  .ListColumns.Add 6
  .HeaderRowRange(6) = "Type"
  ' Make count column in position 7
  .ListColumns.Add 7
  .HeaderRowRange(7) = "Count"
  rowCount = .DataBodyRange.rows.Count
    For i = rowCount To 0 Step -1
      For j = 1 To 3
        oldRow = i
        newRow = i + j
        Set loRow = .ListRows.Add(newRow)
        For k = 1 To 5
          .DataBodyRange(newRow, k).Value = .DataBodyRange(oldRow, k).Value
        Next
        Select Case j
          Case 1
            .DataBodyRange(newRow, 6).Value = "Direct"
            .DataBodyRange(newRow, 7).Value = .DataBodyRange(oldRow, 8).Value
          Case 2
            .DataBodyRange(newRow, 6).Value = "Indirect"
            .DataBodyRange(newRow, 7).Value = .DataBodyRange(oldRow, 10).Value + _
            .DataBodyRange(oldRow, 11).Value + _
            .DataBodyRange(oldRow, 12).Value + _
            .DataBodyRange(oldRow, 13).Value
          Case 3
            .DataBodyRange(newRow, 6).Value = "Total"
            .DataBodyRange(newRow, 7).Value = _
              .DataBodyRange(newRow - 1, 7).Value + _
              .DataBodyRange(newRow - 2, 7).Value
        End Select
      Next
      .ListRows(oldRow).Delete
    Next i
  .ListColumns("DirHeadCount").Delete
  .ListColumns("GenHeadCount").Delete
  .ListColumns("AdmHeadCount").Delete
  .ListColumns("QAQCHeadCount").Delete
  .ListColumns("NCSOHeadCount").Delete
  .ListColumns("HrsPer").Delete
  .ListColumns("CommHeadCount").Delete
End With
Application.ScreenUpdating = True
End Sub

 

[timfritsch]

Have you tried changing automatic calculation to manual? Similar to Application.Screenupdating = False
Application.Calculation = xlCalculationManual

To reset:
Application.Calculation.xlCalculationAutomatic


Hope this helps.


Tim

 

[Fazza]

hi, Chris

best to post description of what is happening

where does the source data come from? how?

what does it look like?

what changes are wanted?

please include some sample data both before & after

which version/s of Excel?

regards

 

[blacksmoke]

Hi,
Thanks for the replies. I've managed to get the time down form ~170min to about ~14 sec !!
I rewrote the sub with the following changes:
I turned off screen updates temporarily
I put calculations in manual mode temporarily
I used 2 arrays instead of trying to loop through and modify a single table.

see below:

Function CleanDataArray()
  Dim lo As Range
  Dim shift As Integer
  Dim array1 As Variant
  Dim array2 As Variant
  Dim row1 As Long
  Dim row2 As Long
  Dim i As Long
  Dim j As Long
  Dim X As Date
  Dim X0 As Date
  Dim D1 As Integer
  Dim D2 As Integer
  Dim m As Long
  Dim n As Long
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set lo = Worksheets("Raw Data").ListObjects("Table_ExternalData_1").DataBodyRange
  array1 = lo.Value
  ReDim array2(LBound(array1) To UBound(array1) * 3, 1 To 9)
  For i = LBound(array1, 1) To UBound(array1, 1)
    row1 = i
    row2 = i * 3 - 2
    For j = 0 To 3
      Select Case j
        Case 0
          ' Calculate the shift
          X = array1(row1, 1)
          XO = Worksheets("Shift Settings").Range("F3").Value
          D1 = Worksheets("Shift Settings").Range("F4").Value
          D2 = Worksheets("Shift Settings").Range("F5").Value
          shift = addShiftCol(D1, D2, X0, X)
          ' Set the first 4 rows of array2 equal to those of array1 for the current record.
          For n = 0 To 2
            array2(row2 + n, 5) = shift
            For m = 1 To 4
              array2(row2 + n, m) = array1(row1, m)
            Next
          Next
        Case 1
          array2(row2, 6) = "Direct"
          array2(row2, 7) = array1(row1, 5)
        Case 2
          array2(row2 + 1, 6) = "InDirect"
          array2(row2 + 1, 7) = 0
          For m = 6 To 10
            array2(row2 + 1, 7) = array2(row2 + 1, 7) + array1(row1, m)
          Next
        Case 3
          array2(row2 + 2, 6) = "Total"
          array2(row2 + 2, 7) = array2(row2 + 1, 7) + array2(row2 + 2, 7)
      End Select
    Next
  Next i
  
  ' Range("N1").Resize(UBound(array2, 1), UBound(array2, 2)) = array2
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  CleanDataArray = array2
End Function

 

[Fazza]

A bit hard to advise without knowing what is happening, Chris. No point in me guessing. Cheers