Speed up code that copies value to a table from a Gantt model

[Swayzy]

Hello


I have a simple code that extracts values from Gantt model to a normal table. The Gantt model is on a per day basis and can be user define to how years needed for a project so it can become alot of days plus there will be a fair few rows with data. So to create a more interactive output from the model I want to transfer the data into a normal style table from which I can create Pivots and Pivot charts. Considering that the model might be edited in a situation were the user is in a meeting and want to be able to update it while there I need this code preferably to run faster.

The code is a double loop that loops all rows for each column (day) and just moves the designated column values over. I didnt really check the time when it ran but it took probably over 10min and it made 1500 rows in the table and that is with minimal inputs in the Gantt model.

Any help, tips or tricks would be very welcome!

(OBS! As of now this is a concept code so the column structure will be altered)

Sub BuildPivotTable()Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Dim Val As String
Dim sht1 As Worksheet
Set sht1 = Sheet6
stcol = Range("StartColumn").Column
ColEnd = Range("EndColumn").Column + 1
LabelCol = Range("Labels").Column
RowDate = Range("StartColumn").Row


ColPiv = Range("PivotCol").Column
Leg = "Leg"
Area = "Area"


RowX = 10


PivotCol1 = Cells(1, ColPiv)
PivotCol2 = Cells(1, ColPiv).Offset(0, 1)
PivotCol3 = Cells(1, ColPiv).Offset(0, 2)
PivotCol4 = Cells(1, ColPiv).Offset(0, 3)
PivotCol5 = Cells(1, ColPiv).Offset(0, 4)
PivotCol6 = Cells(1, ColPiv).Offset(0, 5)
PivotCol7 = Cells(1, ColPiv).Offset(0, 6)
PivotCol8 = Cells(1, ColPiv).Offset(0, 7)
PivotCol9 = Cells(1, ColPiv).Offset(0, 8)
PivotCol10 = Cells(1, ColPiv).Offset(0, 9)
PivotCol11 = Cells(1, ColPiv).Offset(0, 10)
PivotCol12 = Cells(1, ColPiv).Offset(0, 11)
PivotCol13 = Cells(1, ColPiv).Offset(0, 12)
PivotCol14 = Cells(1, ColPiv).Offset(0, 13)
PivotCol15 = Cells(1, ColPiv).Offset(0, 14)
PivotCol16 = Cells(1, ColPiv).Offset(0, 15)






Do Until stcol = ColEnd
Row1 = Range("Frequency").Row + 2
Row2 = Range("EndOFContract").Row - 1


    Do Until Row1 = Row2
    
    If sht1.Cells(Row1, LabelCol) <> "" _
    And sht1.Cells(RowDate, stcol) >= sht1.Cells(Row1, PivotCol3) _
    And sht1.Cells(RowDate, stcol) <= sht1.Cells(Row1, PivotCol6) _
    And sht1.Cells(Row1, stcol) <> "" Then
    Val = ""
    
    Cells(RowX, 4) = sht1.Cells(Row1, LabelCol)
    Cells(RowX, 5) = sht1.Cells(RowDate, stcol)
    Cells(RowX, 6) = sht1.Cells(Row1, PivotCol1)
    Cells(RowX, 7) = sht1.Cells(Row1, PivotCol2)
    Cells(RowX, 8) = sht1.Cells(Row1, PivotCol3)
    Cells(RowX, 9) = sht1.Cells(Row1, PivotCol4)
    Cells(RowX, 10) = sht1.Cells(Row1, PivotCol5)
    Cells(RowX, 11) = sht1.Cells(Row1, PivotCol6)
    Cells(RowX, 12) = sht1.Cells(Row1, PivotCol7)
    Cells(RowX, 13) = sht1.Cells(Row1, PivotCol8)
    Cells(RowX, 14) = sht1.Cells(Row1, PivotCol9)
    Cells(RowX, 15) = sht1.Cells(Row1, PivotCol10)
    
    If sht1.Cells(Row1, PivotCol11) <> "" Then
    Val = sht1.Cells(RowDate, PivotCol11)
    End If
    If sht1.Cells(Row1, PivotCol11 + 1) <> "" Then
    Val = sht1.Cells(RowDate, PivotCol11 + 1)
    End If
    If sht1.Cells(Row1, PivotCol11 + 2) <> "" Then
    Val = sht1.Cells(RowDate, PivotCol11 + 2)
    End If
    Cells(RowX, 16) = Val
        
    Val = sht1.Cells(Row1, PivotCol12)
    Val = sht1.Cells(Row1, PivotCol12 + 1)
    Val = sht1.Cells(Row1, PivotCol12 + 2)
    Cells(RowX, 17) = Val
    
    Cells(RowX, 18) = sht1.Cells(Row1, PivotCol13)
    Cells(RowX, 19) = sht1.Cells(Row1, PivotCol14)
    Cells(RowX, 20) = sht1.Cells(Row1, PivotCol15)
    Cells(RowX, 21) = sht1.Cells(Row1, PivotCol16)
    
    If sht1.Cells(Row1, LabelCol) = Leg Or sht1.Cells(Row1, LabelCol) = Area Then
    Cells(RowX, 22) = sht1.Cells(Row1, stcol)
    Cells(RowX, 23) = sht1.Cells(Row1 + 1, stcol)
    Cells(RowX, 24) = sht1.Cells(Row1 + 2, stcol)
    Else
    Cells(RowX, 22) = sht1.Cells(Row1, stcol)
    Cells(RowX, 24) = sht1.Cells(Row1 + 1, stcol)
    End If
      
    
    RowX = RowX + 1
    End If
    
    
    Row1 = Row1 + 1
    Loop


stcol = stcol + 1
Loop




Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[offthelip]

Your code suffers from exactly the same problem as is described in this thread, and you can solve it by doing exactly the same thing, stop looping through the workhsheet. load everything into variant arrays, copy to onme or more variant arrays and write it back.
https://www.mrexcel.com/forum/excel-questions/1100262-code-running-super-slow.html

 

[Swayzy]

I just read through the thread and I understand what you mean besides the point about copying to another variant array and write it back? Do you mean that I "build" my output table in an array in the code then write that entire array back to the sheet table in one line?

 

[offthelip]

Yes