Code is running SUPER SLOW

[Johnny Thunder]

Hi Group,

I have finally completed my code that is currently looping on 641 Rows of data and its taking exactly 5Mins.... I know this doesn't sound too bad but it is taking waaaaay to long.

I am looking for some improvements or for some modifications to shorten or help speed up what I am trying to do.

Explanation of what the code is doing

1. Code loops down a range of Cells (Column K) and if there is a value present (Text) and a Dollar amount offset two cells over then process this row as needing to have some values dropped in.
2. The values that are dropped in are defined by some declarations in the code.
3. There is a value $Amt, a Percentage and a count of how many columns of values are needed all in the declarations.
4. I needed to make the code as dynamic as possible. I end up using the buttons to trigger the code on 4 other sheets within the same workbook since the structure of each sheet is the same and the only thing that differs are 1 variable designated by the sheet name.

Hoping someone sees something that I missed or has a better way of getting this done. I tried to comment the code up as much as possible to explain what each line or block of lines are doing.

Sub TimelineMap()


Dim ws                     As Worksheet, ws2 As Worksheet
Dim CreativePercent As Range, PerformancePercent As Range, MediaPercent As Range, CategoryRange As Range, Amt2 As Range, ColumnStart As Range, DateBlock As Range, Block As Range, Cell As Range, PHolder1Percent As Range, PHolder2Percent As Range
Dim CreativeCount   As Variant, PerformanceCount As Variant, MediaCount As Variant, NewColNum As Long, RowCount As Variant, PHolder1Count As Variant, PHolder2Count As Variant, LastCol As Variant, Shiftback As Variant
Dim Category           As String, Amount As Variant, ReleaseDate As String, CreativeSpend As String, PerformanceSpend As String, MediaSpend As String, PHolder1Spend As String, PHolder2Spend As String, OffsetStart As String, SheetName As String, CategoryName As String
Dim lastR                 As Long


Application.Volatile


Set ws = Sheets("Master Data")
SheetName = ActiveSheet.Shapes(Application.Caller).Parent.Name 'Creates dynamic sheetname based on button press
CategoryName = Split(SheetName, " - ")(1) 'Gets second half of Sheetname "Scripted"


Set ws2 = Sheets(SheetName) 'Dynamic Sheetname
lastR = ws2.Cells(Rows.Count, "K").End(xlUp).Row
LastCol = Split(ws2.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Cells.Address(1, 0), "$")(0) 'Finds last column with Data


'Defines the Group Names (i.e Creative Spend) - Made to be dynamic in the event the group names change
CreativeSpend = ws.Range("P6").Value
PerformanceSpend = ws.Range("P11").Value
MediaSpend = ws.Range("P16").Value
PHolder1Spend = ws.Range("P21").Value
PHolder2Spend = ws.Range("P26").Value


Set CreativePercent = ws.Range("S8:AO8").SpecialCells(xlCellTypeConstants)   'Copies percentages
Set PerformancePercent = ws.Range("S13:AO13").SpecialCells(xlCellTypeConstants)   'Copies percentages
Set MediaPercent = ws.Range("S18:AO18").SpecialCells(xlCellTypeConstants)    'Copies percentages
Set PHolder1Percent = ws.Range("S23:AO23").SpecialCells(xlCellTypeConstants) 'Copies percentages
Set PHolder2Percent = ws.Range("S28:AO28").SpecialCells(xlCellTypeConstants) 'Copies percentages


'Shiftback = ws.Range("R13:AO13").Find(What:="*", LookAt:=xlPart, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Offset(-1, 0).Value


'Counts how many columns of data will be needed for each row, -1 to step back one column from the start
CreativeCount = Application.WorksheetFunction.CountA(ws.Range("S8:AO8")) - 1
PerformanceCount = Application.WorksheetFunction.CountA(ws.Range("S13:AO13")) - 1
MediaCount = Application.WorksheetFunction.CountA(ws.Range("S18:AO18")) - 1
PHolder1Count = Application.WorksheetFunction.CountA(ws.Range("S23:AO23")) - 1
PHolder2Count = Application.WorksheetFunction.CountA(ws.Range("S28:AO28")) - 1


'Copy block that has all the formatting and formulas as a base to start from
Set Block = ws2.Range("K7:K" & lastR & "")
Set DateBlock = ws2.Range("P4:" & LastCol & "4") 'Header row with dates for Search
OffsetStart = 11    'Defines the start position of the Offset formulas (currently Column K = 11)


    For Each Cell In Block
        If Cell <> vbNullString And Cell.Offset(0, 2) <> 0 Then
           Category = Cell.Offset(0, 1).Value
           
    'Clear all declarations
    Amount = vbNullString
    NewColNum = Empty
    RowCount = vbNullString
    Set ColumnStart = Nothing
           
        Select Case Category
                Case CreativeSpend
                    Amount = Cell.Offset(0, 2).Value    'Stays the same on all
                        ReleaseDate = Format(Cell.Offset(5, -3).Value, "mmm-yy")    'Converts the found date into the format "mmm-yy"
                            Set ColumnStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ReleaseDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
                         CreativePercent.Copy
                     NewColNum = ColumnStart.Column - OffsetStart - CreativeCount
                 Set Amt2 = Cell.Offset(0, 2)
                RowCount = CreativeCount
                
                Case PerformanceSpend
                    Amount = Cell.Offset(0, 2).Value    'Stays the same on all
                        ReleaseDate = Format(Cell.Offset(4, -3).Value, "mmm-yy")    'Converts the found date into the format "mmm-yy"
                            Set ColumnStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ReleaseDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
                         PerformancePercent.Copy
                     NewColNum = ColumnStart.Column - OffsetStart - PerformanceCount
                   Set Amt2 = Cell.Offset(0, 2)
                RowCount = PerformanceCount
                
                 Case MediaSpend
                    Amount = Cell.Offset(0, 2).Value    'Stays the same on all
                        ReleaseDate = Format(Cell.Offset(3, -3).Value, "mmm-yy")    'Converts the found date into the format "mmm-yy"
                            Set ColumnStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ReleaseDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
                         MediaPercent.Copy
                     NewColNum = ColumnStart.Column - OffsetStart - MediaCount
                    Set Amt2 = Cell.Offset(0, 2)
                RowCount = MediaCount
                    
                Case PHolder1Spend
                    Amount = Cell.Offset(0, 2).Value    'Stays the same on all
                        ReleaseDate = Format(Cell.Offset(2, -3).Value, "mmm-yy")    'Converts the found date into the format "mmm-yy"
                            Set ColumnStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ReleaseDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
                         PerformancePercent.Copy
                     NewColNum = ColumnStart.Column - OffsetStart - PHolder1Count
                    Set Amt2 = Cell.Offset(0, 2)
                RowCount = PerformanceCount
                
                 Case PHolder2Spend
                    Amount = Cell.Offset(0, 2).Value    'Stays the same on all
                        ReleaseDate = Format(Cell.Offset(1, -3).Value, "mmm-yy")    'Converts the found date into the format "mmm-yy"
                            Set ColumnStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ReleaseDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
                         MediaPercent.Copy
                     NewColNum = ColumnStart.Column - OffsetStart - PHolder2Count
                    Set Amt2 = Cell.Offset(0, 2)
                RowCount = MediaCount
                
        End Select
        
       If Amount = 0 Then
            'Do nothing
       Else
            Cell.Offset(0, NewColNum).PasteSpecial xlPasteValues    'Drops in the Value based on the Category and Release date
                Amt2.Copy
                    Range(Cell.Offset(0, NewColNum), Cell.Offset(0, NewColNum + RowCount)).PasteSpecial xlPasteValues, xlMultiply 'Drops in the Value based on the Category and Release date
                    Application.CutCopyMode = False
        End If  'Amount End if
                End If  'For Each End if
        
        Next Cell '1st For each


    'Named Range Update
    With ActiveWorkbook.Names(CategoryName & "Box")
            .Name = CategoryName & "Box"
               .RefersTo = "='" & SheetName & "'!$P$7:$GA$" & lastR & ""
                 Application.ScreenUpdating = False
                     Application.DisplayAlerts = False
            End With


    'Named Range Update
       With ActiveWorkbook.Names(CategoryName & "Col")
               .Name = CategoryName & "Col"
                  .RefersTo = "='" & SheetName & "'!$L$7:$L$" & lastR & ""
                    Application.ScreenUpdating = False
                        Application.DisplayAlerts = False
               End With
        
End Sub

 

[Johnny Thunder]

Re: VBA Help - Code is running SUPER SLOW! - Any help or improvements please!

Ok, I have made several changes to the code but now I am getting an error on the line "Range(Block(i, ProdStart), Block(i, ProdEnd - 1)) = ProdPercent 'Enters the Prod Sched" - Method Range of Object '_ Global Failed. Any ideas why?

Here is the revised code, hoping with all the changes you proposed the code will run way faster (Under 60 seconds would be the goal)

'--------------------------------------------------------------------------
'--- Creates Tiring of Amounts on - Timeline - Scripted
'--------------------------------------------------------------------------
Sub TimelineMapTester()


Dim ws1                   As Worksheet, ws2 As Worksheet
Dim CreativePercent As Range, CategoryRange As Range, Amt2 As Range, ColumnStart As Range, ProdPercent As Variant, RelPercent As Variant, Cell As Range, Cell2 As Range, LastCol2 As Variant
Dim CreativeCount   As Variant, RowCount As Variant, LastCol As Variant, Amount As Variant, Block As Variant, MaxDate As Variant, i As Variant, k As Variant, j As Variant, ProdStart As Variant, ProdEnd As Variant
Dim OffsetStart        As String, SheetName As String, CategoryName As String, ProdDate As String, ProdEndDate As String, Category As String, ReleaseDate As String, CreativeSpend As String
Dim lastR                 As Long
Dim ProdCount        As Integer, RelCount As Integer


Set ws1 = Sheets("Master Data")
SheetName = ActiveSheet.Name 'Creates dynamic sheetname based on button press
CategoryName = Split(SheetName, " - ")(1) 'Gets second half of Sheetname "Scripted"


Set ws2 = Sheets(SheetName) 'Dynamic Sheetname
lastR = ws2.Cells(Rows.Count, "K").End(xlUp).Row


MaxDate = Application.WorksheetFunction.Max(Columns("J")) 'Finds the latest date in my range
MaxDate = Format(CDate(MaxDate), "mmm-yy") 'Defines date in a format that can be searched to determine the last column of Data


LastCol = Split(ws2.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Cells.Address(1, 0), "$")(0) 'Finds last column with Data returns column letter
LastCol2 = ws2.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column 'Finds last column with Data returns column letter


'Defines the Group Names (i.e Creative Spend) - Made to be dynamic in the event the group names change
CreativeSpend = ws1.Range("P6").Value


ProdPercent = ws1.Range("AE8")  '70%
RelPercent = ws1.Range("AF8")  '30%


'Copy block that has all the formatting and formulas as a base to start from
Block = Range(Cells(1, 1), Cells(lastR, LastCol)) 'Defines the Title Block


    For i = 1 To lastR  ' This is because your array starts at row 3
        If Block(i, 13) <> vbNulstring And Block(i, 15) <> 0 And Block(i, 14) = "Creative Spend" Then
                      
    'Clear all declarations
    Amount = vbNullString
    NewColNum = Empty
    RowCount = vbNullString
               
                    Amount = Block(i, 15)  'Stays the same on all
                        ReleaseDate = Format(Block(i + 5, 10), "mmm-yy")  'Converts the found date into the format "mmm-yy"
                            ProdDate = Format(Block(i + 5, 8), "mmm-yy")   'Converts the found date into the format "mmm-yy"
                                ProdEndDate = Format(Block(i + 5, 9), "mmm-yy")  'Converts the found date into the format "mmm-yy"
                                    ProdCount = DateDiff("m", Block(i + 5, 8), Block(i + 5, 9)) - 1 'Get Count of Months Between Prod Start & Stop, -1 due to 1st month has no activity
                                        RelCount = DateDiff("m", Block(i + 5, 9), Block(i + 5, 10))  'Get Count of Months Between Prod End & Release
                                     
                                For k = 18 To LastCol2
                                    If Format(Block(4, k), "mmm-yy") = ProdDate Then
                                    ProdStart = k   'Used to get Column Location to drop values
                                    ElseIf Format(Block(4, k), "mmm-yy") = ProdEndDate Then
                                    ProdEnd = k  'Used to get Column Location to drop values
                                    End If
                                Next k
                                                               
                                Range(Block(i, ProdStart), Block(i, ProdEnd - 1)) = ProdPercent 'Enters the Prod Sched .   '<-----------Error Line
                            Range(Block(i, ProdEnd), Block(i, ProdEnd + RelCount - 1)) = RelPercent 'Enters the Release Sched
                        
                        Block(i, 9).Copy  'Copies Amount
                      Range(Block(i, ProdStart), Block(i, ProdEnd + RelCount - 1)).PasteSpecial xlPasteValues, xlMultiply 'Multiplies the percentages the code above dropped in by a specified amount on the clipboard


                Range(Block(i, ProdStart), Block(i, ProdEnd - 1)) = Selection.Parent.Evaluate("INDEX(" & Selection.Address & "/" & ProdCount + 1 & ",)") 'Divides the above range by a specified count of values for each block entered
                Range(Block(i, ProdEnd), Block(i, ProdEnd + RelCount - 2)).Value = Selection.Parent.Evaluate("INDEX(" & Selection.Address & "/6" & ",)") 'Divides the above range by a specified count of values for each block entered


                Application.CutCopyMode = False


                End If  'For i End if
        
        Next i
        
End Sub

 

[offthelip]

Re: VBA Help - Code is running SUPER SLOW! - Any help or improvements please!

Range(Block(i, ProdStart), Block(i, ProdEnd - 1)) = ProdPercent 'Enters the Prod Sched . '<-----------Error Line Range(Block(i, ProdEnd), Block(i, ProdEnd + RelCount - 1)) = RelPercent 'Enters the Release Sched

Block(i, 9).Copy 'Copies Amount
Range(Block(i, ProdStart), Block(i, ProdEnd + RelCount - 1)).PasteSpecial xlPasteValues, xlMultiply 'Multiplies the percentages the code above dropped in by a specified amount on the clipboard




Range(Block(i, ProdStart), Block(i, ProdEnd - 1)) = Selection.Parent.Evaluate("INDEX(" & Selection.Address & "/" & ProdCount + 1 & ",)") 'Divides the above range by a specified count of values for each block entered
Range(Block(i, ProdEnd), Block(i, ProdEnd + RelCount - 2)).Value = Selection.Parent.Evaluate("INDEX(" & Selection.Address & "/6" & ",)") 'Divides the above range by a specified count of values for each block entered

this is all more code where you appear to trying to write to the worksheet in a loop , ( I assume that is why you have got "range" in front of the block bits. The syntax is all wrong because a range statement be in a format that excel can understand.)
You could correct the format by changing it to :

Range ( cells(i,prodend),cells(I,prodend+relcount -2)).value

which will write something to the workhseet, but it will be slow because you are accessing the worksheet in a loop ( forbidden in my rules except for formatting)
To avoid writing to the worksheet in a loop define an output array from row 1 to lastr from column 18 to lastcol2
Then write the values out to the array in the loop and only after fininshing the loop write the entire array to the worksheet
some where at the top

outarr= range(cells(1,18),cells(lastr,lastcol))
'then instead of the lines where the error is above:
for indi = prodstart to prodend -1
outarr(I,indi)=prodcent
next indi
for indi = prodend to prodend +relcount-1
outarr(I,indi)=relpercent
next indi
' after the end of the I  loop you put 
range(cells(1,18),cells(lastr,lastcol))=outarr

you then appear to have some code doing some multiplication by a value on the clipboard, and then doing someting that depends on the selection address, both of these sound like a terrible ideas to me, very likely to fail if the macro gets interupted by anything, and also totally unclear to anybody trying to maintain the software as to what hell it is doing.
so I suggest rewriting this bit doing the maths in VBA and make it clear what it is doing.

doing arithmetic and

 

[offthelip]

Re: VBA Help - Code is running SUPER SLOW! - Any help or improvements please!

Sorry i made an error in my code, it should be:

outarr(I,indi-18)=prodcent

And the same for relpercent.
This is because the indexing for the array starts at 1 which is equivalent to column 18.