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

 

[offthelip]

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

One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
So if I were you I would change the code so instead of :

[COLOR=#333333]Set Block = ws2.Range("K7:K" & lastR & "")[/COLOR]

Load all of this data into an array e.g:

Dim BLock as Variant
[COLOR=#333333]Block = ws2.Range("K7:N" & lastR & "") ' note I have include more that one column to allow for your offsets further on[/COLOR]

you then have all exactly the same data in memory and you can loop through about 1000 times faster
i.e

For i = 1 to lastr-7 ' This is becaus your array starts at row 7
 if block(i,1) <> vbNulstring and block(i,3) <> 0 then
etc

there are loads more changes that you could do, I would expect to get the time down to less than 1 second.
The only thing that is going to take any time is the formatting

 

[Johnny Thunder]

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

This is great! Exactly what I was looking for. I will work on making the updates to the code and report back my findings with this method. I appreciate you taking the time to write all that out.

 

[mikerickson]

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

Just at my very first glance.

SheetName = ActiveSheet.Shapes(Application.Caller).Parent.Name

can be replaced with

SheetName = ActiveSheet.Name

 

[Johnny Thunder]

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

Ok, question:

I have made the updates you suggested above but alot of my code was using the For Each CELL reference and since I am using the For i Reference now, several of my lines of code look like Format(Cell.Offset(3, -3).Value, "mmm-yy")

I would assume the updated version would look like Format(Block(i,0).Offset(3, -3).Value, "mmm-yy") but I keep getting a Subscript out of range error.

I assume I am doing something wrong. It was clear when the Block(i,1) moves to the right but how do I offset up and down if that is in place of the "i"? And can this also work for moving backwards to the left of a cell? Like Offset(5,-3) ?

 

[Michael M]

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

you could also turn

application.Screenupdating=False

at the beginning of your code

and back to true at the end of your code

 

[Johnny Thunder]

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

This code that was posted is being called by another macro, the first macro runs in less than a second and has the ScreenUpdating and DisplayAlerts off and back on at the end. Didn't do much aside from the screen flickering.

 

[offthelip]

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

Ok, question:

I have made the updates you suggested above but alot of my code was using the For Each CELL reference and since I am using the For i Reference now, several of my lines of code look like Format(Cell.Offset(3, -3).Value, "mmm-yy")

I would assume the updated version would look like Format(Block(i,0).Offset(3, -3).Value, "mmm-yy") but I keep getting a Subscript out of range error.

I assume I am doing something wrong. It was clear when the Block(i,1) moves to the right but how do I offset up and down if that is in place of the "i"? And can this also work for moving backwards to the left of a cell? Like Offset(5,-3) ?

As I hinted in my reply the formatting is the problem which you have to treat differently. If you try formatting a variant array what you are trying to do is format a location in computer memory NOT the worksheet, so fairly obviously that doesn't work You have to format the cell on the worksheet. However it is fairly easy to do because you can use the same indexing, in the example I gave above where the array is loaded from K7 to N lastrow assume you indexing through this and the row is determined by your index "i" so assuming you want to format the row three below that row and two to the right of you current value in column K. Column K is column number 11 , the row is given by i, so to format three below and two to the right we get:

Range(Cells(i+3, 9), Cells(i+3, 9)).Font.Color = vbRed   ' the 9 is 11 -2

what you also need to be aware is that you need to split up the assigning the variable to the cell and the formatting of the cell. If you are writing a load of values to the worksheet,, it is best to define an "output" array, and write all the values to the output array and then only write the array back when the loop is complete.
What I have often done is also define another array where I keep track of the formatting needed (in the loop), and then run through that array at the end of the loop to do the formatting

 

[Johnny Thunder]

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

@offthelip

So I have made several adjustments using your proposed solution and I was able to get the code down to 3Min. I still think there is something bogging down the code but not really familiar with the For i option instead of the For Each Cell option.

Do you see anything in this revised code that could be improved on? The code will look much shorter than the previous code since I did a little bit of cleanup and am only processing one scenario in this code "Creative Spend". Once I get the code to run in seconds like you stated the code could potentially run in I will add in the other two scenarios.

'--------------------------------------------------------------------------
'--- 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, DateBlock As Range, ProdStart As Range, ProdEnd As Range, ProdPercent As Range, RelPercent As Range, Cell As Range, Cell2 As Range, LastCol2 As Range
Dim CreativeCount   As Variant, RowCount As Variant, LastCol As Variant, Amount As Variant, Block As Variant, Ma_xDate 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


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


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


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


Set ProdPercent = ws1.Range("AE8")  '70%
Set RelPercent = ws1.Range("AF8")  '30%
Set CreativePercent = ws1.Range("S8:AO8").SpecialCells(xlCellTypeConstants)   'Copies percentages


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


    For i = 1 To lastR - 7 ' This is because your array starts at row 7
        If Block(i, 7) <> vbNulstring And Block(i, 9) <> 0 And Block(i, 8) = "Creative Spend" Then
                      
    'Clear all declarations
    Amount = vbNullString
    NewColNum = Empty
    RowCount = vbNullString
    Set ColumnStart = Nothing
           
                    Amount = Block(i, 9)  'Stays the same on all
                        ReleaseDate = Format(Block(6, 4), "mmm-yy")    'Converts the found date into the format "mmm-yy"
                            ProdDate = Format(Block(6, 2), "mmm-yy")     'Converts the found date into the format "mmm-yy"
                                ProdEndDate = Format(Block(6, 3), "mmm-yy")    'Converts the found date into the format "mmm-yy"
                                    ProdCount = DateDiff("m", Block(6, 2), Block(6, 3)) - 1 'Get Count of Months Between Prod Start & Stop, -1 due to 1st month has no activity
                                        RelCount = DateDiff("m", Block(6, 3), Block(6, 4)) 'Get Count of Months Between Prod End & Release
                                            Set ColumnStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ReleaseDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
                                        Set ProdStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ProdDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
                                    Set ProdEnd = ws2.Range("P4:" & LastCol & "4").Find(What:=ProdEndDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
                                
                                Range(Block(i, ProdStart.Column - 12), Block(i, ProdStart.Column - 12 + ProdCount)).Value = ProdPercent.Value  'Enters the Prod Sched
                            Range(Block(i, ProdEnd.Column - 12), Block(i, ProdEnd.Column - 12 + RelCount - 2)).Value = RelPercent.Value 'Enters the Release Sched
                        
                        Block(i, 9).Copy  'Copies Amount
                      Range(Block(i, 15), Block(i, LastCol2.Column - 6)).SpecialCells(xlCellTypeConstants).PasteSpecial xlPasteValues, xlMultiply 'Drops in the Value based on the Category and Release date
                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!

I can't see how your code works at all because you have declared Block and Dateblock as varaint but you are assigning them as though they are Ranges

'Copy block that has all the formatting and formulas as a base to start from
Set Block = ws2.Range("G7:" & LastCol & lastR & "") 'Defines the Title Block

to assign a Variant array DO NOT USE "SET"
e.g

Block = ws2.Range("G7:" & LastCol & lastR & "")  'Defines the Title Block

Note the array does not contain the formatting which is on the worksheet, it just contains the values which are in the range. So you have to treat the formatting completely seperately to manipulating the numbers.

Your code will still be very slow because you are still accessing the worksheet in a loop : this code :

Set ColumnStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ReleaseDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False) Set ProdStart = ws2.Range("P4:" & LastCol & "4").Find(What:=ProdDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)
Set ProdEnd = ws2.Range("P4:" & LastCol & "4").Find(What:=ProdEndDate, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlNext, LookAt:=xlWhole, MatchCase:=True, SearchFormat:=False)

To get rid of this don't use the FIND function do the search using vBA
when you load the BLOCK variant array include all the columns and all the rows that you might need , I would assign BLOCK like this:

Block=range (cells(1,1),cells(lastrow,lastcol)

you then have a mirror image of the worksheet in the array so it makes finding the right index much easier.
so to find "release date" we need to search row 4 from column p to the last column in the array block
I would do it like this
Col P is column 16

 for i = 16 to lastcol
   if Block (4,i)=Releasedate then
      msgbox " release date was found in column " & i 
   end if
next i

I use "SET" to set a Range about once year , it is practically never needed. So try and get rid of all of the "set". That will speed it up