Johnny Thunder
Well-known Member
- Joined
- Apr 9, 2010
- Messages
- 693
- Office Version
- 2016
- Platform
- MacOS
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.
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.
Code:
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