VBA Automation Error - possibly born from my complete lack of understanding with Error Handling

R

RockandGrohl

Well-known Member
Joined
Aug 1, 2018
Messages
801
Office Version
  1. 365
Platform
  1. Windows
Hi all, same kind of topic again. Going to start with a top-to-bottom list of nomenclature

Super Automation - Main workbook which contains a list of newspapers and their requirements, houses all macro code
Automation Hub - Where products are placed and ranked according to various criteria
Advert Data - CSV database containing a list of all products and all advertisements, one line per (this is now approaching 30,000 lines)
Various supplementary files that aid in the Automation Hub such as Regional Press Report, Weekly report, etc.

And here's what happens:

  • We have approximately 600-650 newspaper titles each week. A title is selected and SUPER AUTOMATION is initiated.
  • Information is brought into a temp sheet and a progress box is opened to display current progress.
  • Advert Data is opened and a list of suitable products is found
  • The products are sent to Temp sheet, then loaded into Automation Hub
  • Various supplementary sheets are opened to aid Automation Hub into determining the best product for the newspaper
  • The products are ranked and sent back to the temp sheet, Automation Hub then closes.
  • Now that the rank is ascertained, the top X products as required for the advert are allocated
  • The Advert Data is opened and the newspaper information is added to that product
  • The Advert Data is then saved and closed
  • The Super Automation saves and that's one loop completed out of 600+

The problem:

Somewhere within those red lines, I am getting an error message pop up that crashes Excel. It says "Automation Error" and that's it. No code, the VBA window doesn't display where the error is, and if I press "OK" Excel just closes and reopens. I can then press SUPER AUTOMATION again and it will continue on as if nothing happened. It will carry on for 1, 2, 5, 10 or even 100 iterations, then it will crash again, without warning and with no explanation.

Another problem:

Sometimes the Macro will just stop running silently and I still have full control of the sheet, so I can restart it again. This is what leads me to believe it's an on error.

Solutions I've tried:

  • Removing all macros from Automation Hub.xlsm and saving to .xlsx
  • Doing all Office Updates
  • Running files as Admin
  • Keeping the Super Automation file on the system drive instead of a network drive
  • Crying
  • Stepping through code line by line (and it works perfectly)
  • Stepping through code in portions (and it works perfectly)
  • Praying
  • Commenting out "On Error _____" segments, but there are situations outside of my control, like looking for a sheet that may be missing.

I think it may be my poor usage of On Error. In summary, I want this sheet to run overnight, so if there's a problem with any one of the 600+ rows, I'd rather it just skips that row and I can deal with it in the morning. I'd rather it does 400 with 200 skipped errors, instead of getting to row 30 then copping out and I then have to do another 570.

So in any places where I think there could be an error (for example, no applicable products to transfer from Advert Data to Temp sheet) I want it to "GoTo Skip" and just skip over everything, the "Skip:" portion is literally just return to main tab, iterate to the next line down, repeat.

Below is my code, and I think the error is manifesting itself in the "Call: Super Automation" portion, so I've posted that too. Sorry for the mammoth posting.


Super Automation Code
Code: 
Private Sub SuperAuto_Click()

Dim Lastrow, LastrowAD As Long, WB As Workbook
Dim TourCopyRng As Range
Dim DateCopyRng As Range
Dim NameCopyRng As Range
Dim CostCopyRng As Range




Set ads = Worksheets("Adselect")
Set atm = Worksheets("ATM")
Set am = Worksheets("AM")
Set AMPD = Worksheets("AMPD")
Set cap = Worksheets("CAP")
Set tod = Worksheets("TOD")
Set mt = Worksheets("MacroTimings")
Set tt = Worksheets("Theatre Tours")
Set rs = Worksheets("Rail Supplement")
Set WB = ActiveWorkbook
wbyr = 2019


Application.ScreenUpdating = False
ControlPanel.Hide




Overwrite = False




Dim start_time, end_time
mt.Range("F2").Value = Format(Now(), "hh:mm:ss")


On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Temp").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add.Name = "Temp"
Set temp = Worksheets("Temp")


ads.Activate
WCD = Range("A1").Value
WCDV = DateValue(Range("A1").Value)
JGtdate = WCDV + 42
OMtdate = WCDV + 21


Omega = False
JG = False


Do Until Cells(ActiveCell.Row, "A").Value = "" ' Main Loop
start_time = Now()
Success = False


If Cells(ActiveCell.Row, "G").Value = "" Then
MsgBox "No template in current ad!"
Exit Sub
End If


If Overwrite = False And Cells(ActiveCell.Row, "E").Value = "Y" Then
    GoTo Skip
End If




If Cells(ActiveCell.Row, "A").Value = "JP Filler Ads" Then
    Call JPFiller
    GoTo Skip
End If


If Overwrite = False Then
    Do Until Cells(ActiveCell.Row, "E").Value = ""
    ActiveCell.Offset(1, 0).Activate
    Loop
End If


PapNam = Cells(ActiveCell.Row, "A").Value
template = Cells(ActiveCell.Row, "G").Value
templatesize = Cells(ActiveCell.Row, "C").Value
AdVal = Cells(ActiveCell.Row, "D").Value
comp = Cells(ActiveCell.Row, "F").Value
tourreq = Cells(ActiveCell.Row, "H").Value


If InStr(Cells(ActiveCell.Row, "G").Value, "TH_") > 0 Then
Theatre = True
Else
Theatre = False
End If


ProgBox.ProgTitleNameFront.Caption = PapNam
ProgBox.ProgTitleNameBack.Caption = PapNam
ProgBox.TemplateLabelFront = template
ProgBox.TemplateLabelBack = template
ProgBox.ProgStatusFront.Caption = Range("H1").Value
ProgBox.ProgStatusBack.Caption = Range("H1").Value


Load ProgBox
With ProgBox
  .StartUpPosition = 0
  .Left = Application.Left + (0.05 * Application.Width) - (0.05 * .Width)
  .Top = Application.Top + (0.05 * Application.Height) - (0.05 * .Height)
  .Show vbModeless
End With


If Cells(ActiveCell.Row, "F").Value = "Just Go" Then
JG = True
Omega = False
Else
Omega = True
JG = False
End If


EU = False
Rail = False
Air = False
SD = False




If Cells(ActiveCell.Row, "K").Value = "Y" Then
EU = True
End If
If Cells(ActiveCell.Row, "L").Value = "Y" Then
Rail = True
End If
If Cells(ActiveCell.Row, "M").Value = "Y" Then
Air = True
End If
If Cells(ActiveCell.Row, "N").Value = "Y" Then
SD = True
End If
If SD = False And Rail = False And Air = False Then
Coach = True
End If


temp.Activate
Cells.ClearContents
temp.Range("A1").Value = "Paper Name"
temp.Range("A2").Value = PapNam
temp.Range("A3").Value = template
temp.Range("A4").Value = templatesize
temp.Range("A5").Value = tourreq
temp.Range("A6").Value = comp
temp.Range("A7").Value = AdVal
temp.Range("B1").Value = "Primary Pickups"
temp.Range("B2").FormulaR1C1 = "=IFERROR(VLOOKUP(RC1,AMPD!C5:C12,8,0),"""")"
temp.Range("B2").Value = temp.Range("B2").Value
If Coach = True Then
temp.Range("B3").FormulaR1C1 = "=iferror(coachSTR(R2C2),"""")"
temp.Range("B3").Value = temp.Range("B3").Value
End If
If Rail = True Then
temp.Range("B3").FormulaR1C1 = "=iferror(railSTR(R2C2),"""")"
temp.Range("B3").Value = temp.Range("B3").Value
End If
If Air = True Then
temp.Range("B3").FormulaR1C1 = "=iferror(airSTR(R2C2),"""")"
temp.Range("B3").Value = temp.Range("B3").Value
End If


temp.Columns("A:A").EntireColumn.AutoFit


    tempdonk = 0
    Range("B5").Activate
    Do Until tempdonk = 13
    ActiveCell.Value = "Pickup " & tempdonk + 1
    tempdonk = tempdonk + 1
    ActiveCell.Offset(0, 1).Activate
    Loop ' Naming Temp Sheet Pickups Loop


' Splitting Pickups
Range("B2").Copy Range("B6")
Range("B6").Activate
ActiveCell.Replace What:=", ", Replacement:=",", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
ActiveCell.TextToColumns Destination:=Range("B6"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True


' Determining Pickup Travel Type


    Do Until Cells(6, ActiveCell.Column).Value = ""
        
        If ActiveCell Like "Flying*" Then
        ActiveCell.Offset(1, 0).Value = "Air"
        End If
        
        If ActiveCell Like "(RS)*" Then
        ActiveCell.Offset(1, 0).Value = "Rail"
        End If
        
        If ActiveCell Like "Making*" Then
        ActiveCell.Offset(1, 0).Value = "Self Drive"
        End If
        
        If ActiveCell.Offset(1, 0).Value = "" Then
        ActiveCell.Offset(1, 0).Value = "Coach"
        End If
        
        ActiveCell.Offset(0, 1).Activate
    Loop ' Pickup Travel Type Loop


' Adding Rail Supplement in


If Rail = True Then
    Range("B7").Activate
    Do Until Cells(7, ActiveCell.Column).Value = ""
    If ActiveCell.Value = "Rail" Then
        ActiveCell.Offset(-3, 0).FormulaR1C1 = "=IFERROR(INDEX('Rail Supplement'!C2,MATCH(Temp!R6C,'Rail Supplement'!C1,0)),0)"
        ActiveCell.Offset(-3, 0).Value = ActiveCell.Offset(-3, 0).Value
        RSUP = ActiveCell.Offset(-3, 0).Value
    End If
    ActiveCell.Offset(0, 1).Activate
    Loop
End If


' Determine what Travel type to go with for the tour


Range("B5").Activate
PUdonk = 0


If Rail = True Then
Range("A8").Value = "Rail"
    Do Until Cells(5, ActiveCell.Column).Value = ""
        If ActiveCell.Offset(2, 0).Value = "Rail" Then
        ActiveCell.Offset(1, 0).Value = "Train to London"
        PUdonk = PUdonk + 1
        ActiveCell.Offset(3, 0).Value = "PU" & PUdonk
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
Range("B5").Activate
PUdonk = 0
End If


If Air = True Then
Range("A8").Value = "Air"
   Do Until Cells(5, ActiveCell.Column).Value = ""
        If ActiveCell.Offset(2, 0).Value = "Air" Then
        PUdonk = PUdonk + 1
        ActiveCell.Offset(3, 0).Value = "PU" & PUdonk
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
Range("B5").Activate
PUdonk = 0
End If


If SD = True Then
Range("A8").Value = "SD"
   Do Until Cells(5, ActiveCell.Column).Value = ""
        If ActiveCell.Offset(2, 0).Value = "Self Drive" Then
        PUdonk = PUdonk + 1
        ActiveCell.Offset(3, 0).Value = "PU" & PUdonk
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
Range("B5").Activate
PUdonk = 0
End If


If Coach = True Then
Range("A8").Value = "Coach"
   Do Until Cells(5, ActiveCell.Column).Value = ""
        If ActiveCell.Offset(2, 0).Value = "Coach" Then
        PUdonk = PUdonk + 1
        ActiveCell.Offset(3, 0).Value = "PU" & PUdonk
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
Range("B5").Activate
PUdonk = 0
End If


' Assign pickups


Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU1" Then
    PU1 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU1 = ""
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU2" Then
    PU2 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU2 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU3" Then
    PU3 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU3 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU4" Then
    PU4 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU4 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU5" Then
    PU5 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU5 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU6" Then
    PU6 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU6 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU7" Then
    PU7 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU7 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU8" Then
    PU8 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU8 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU9" Then
    PU9 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU9 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop
Range("B5").Activate
Do Until Cells(5, ActiveCell.Column) = ""
    If ActiveCell.Offset(3, 0).Value = "PU10" Then
    PU10 = ActiveCell.Offset(1, 0).Value
    Exit Do
    Else
    PU10 = "Blank"
    End If
ActiveCell.Offset(0, 1).Activate
Loop


Application.DisplayAlerts = False


temp.Range("A11").Value = "Applicable Tours"
temp.Range("H11").Value = "Automated Tours"
temp.Range("I11").Value = "Tour Name"
temp.Range("J11").Value = "Price"
temp.Range("K11").Value = "Rank"
temp.Range("L11").Value = "Points"
temp.Range("M11").Value = "Manual Weighting"
adopen = False


Application.DisplayAlerts = True
For Each wbk In Workbooks
    If wbk.Name = "Advert Data " & wbyr & ".csv" Then
    adopen = True
    wbk.Activate
    Set ad = ActiveWorkbook
        If ad.ReadOnly = True Then
        ads.Activate
        ad.Close False
        adopen = False
        End If
    End If
Next
Application.DisplayAlerts = False


If adopen <> True Then
Application.DisplayAlerts = False
Set ad = Workbooks.Open("H:\Sales\Regional Press Selections\" & wbyr & "\Advert Data " & wbyr & ".csv", False, True)
Application.DisplayAlerts = True
Else
Application.DisplayAlerts = False
ad.Activate
Application.DisplayAlerts = True
End If


Application.DisplayAlerts = False


LastrowAD = Cells(Rows.Count, "A").End(xlUp).Row


Set TourCopyRng = Range("A2:A" & LastrowAD)
Set DateCopyRng = Range("E2:E" & LastrowAD)
Set NameCopyRng = Range("C2:C" & LastrowAD)
Set CostCopyRng = Range("G2:G" & LastrowAD)




Range("W2").FormulaArray = "=COUNT(SEARCH({"", " & PU1 & ","","", " & PU2 & ","","", " & PU3 & ","","", " & PU4 & ","","", " & PU5 & ",""},"", ""&RC[-14]&"",""))"
Range("W2").Select
Selection.AutoFill Destination:=Range("W2:W" & LastrowAD)




    
    If JG = True Then
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=5, Criteria1:=">=" & CLng(DateValue(JGtdate))     ' Tour date
    Else
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=5, Criteria1:=">=" & CLng(DateValue(OMtdate))     ' Tour date
    End If
    
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=12, Criteria1:="="                              ' Ad Week blank
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=2, Criteria1:="Active"                          ' Status Active
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=23, Criteria1:=">0"                             ' Applicable Pickup
    If JG = True Then   'Adding Theatre Tours in
    Else
    If Theatre = True Then
    Range("U2:U" & LastrowAD).FormulaR1C1 = "=IF(COUNTIF('[Super Automation.xlsm]Theatre Tours'!C1,RC[-18])>0, ""Y"","""")"
    Range("U2:U" & LastrowAD).Copy
    Range("U2").PasteSpecial xlPasteValues
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=21, Criteria1:="Y"                              ' Theatre
    Else
    Range("U2:U" & LastrowAD).FormulaR1C1 = "=IF(COUNTIF('[Super Automation.xlsm]Theatre Tours'!C1,RC[-18])>0, ""Y"","""")"
    Range("U2:U" & LastrowAD).Copy
    Range("U2").PasteSpecial xlPasteValues
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=21, Criteria1:=""                              ' Non-Theatre
    End If
    End If
    If JG = True Then
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=10, Criteria1:="<>*Omega*", Operator:=xlAnd, Criteria2:="<>*Albion*"
    Else
    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=10, Criteria1:="*Omega*"
        If Rail = True Then
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=3, Criteria1:="*Rail*"
        End If
        If SD = True Then
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=3, Criteria1:="*h&t*"
        End If
        If Coach = True Then
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=3, Criteria1:="<>" & "*airport*"
        End If
        
    End If
    
    


On Error GoTo NoTours
TourCopyRng.SpecialCells(xlCellTypeVisible).Copy temp.Range("A12")
NameCopyRng.SpecialCells(xlCellTypeVisible).Copy temp.Range("B12")
DateCopyRng.SpecialCells(xlCellTypeVisible).Copy temp.Range("C12")
CostCopyRng.SpecialCells(xlCellTypeVisible).Copy temp.Range("D12")
ad.Close False
On Error GoTo 0




temp.Activate
Tourcount = Cells(Rows.Count, "A").End(xlUp).Row - 11
temp.Range("A10").Value = Tourcount


' Scrub away 3rd Party Tours


Range("B12").Activate
Do Until Cells(ActiveCell.Row, "B").Value = ""
    If InStr(1, ActiveCell.Value, "ripsmith", 1) > 0 Then
    Rows(ActiveCell.Row).Delete
    ActiveCell.Offset(-1, 0).Activate
    End If
    If InStr(1, ActiveCell.Value, "ravelzoo", 1) > 0 Then
    Rows(ActiveCell.Row).Delete
    ActiveCell.Offset(-1, 0).Activate
    End If
    If InStr(1, ActiveCell.Value, "owcher", 1) > 0 Then
    Rows(ActiveCell.Row).Delete
    ActiveCell.Offset(-1, 0).Activate
    End If
    If InStr(1, ActiveCell.Value, "tison", 1) > 0 Then
    Rows(ActiveCell.Row).Delete
    ActiveCell.Offset(-1, 0).Activate
    End If
    If InStr(1, ActiveCell.Value, "celolly", 1) > 0 Then
    Rows(ActiveCell.Row).Delete
    ActiveCell.Offset(-1, 0).Activate
    End If
ActiveCell.Offset(1, 0).Activate
Loop


' Now select!
Application.ScreenUpdating = False
Call SuperAutomation.SuperAutomation
Application.ScreenUpdating = False


' Amend Rail Price
If Rail = True Then
Range("J12").Activate
    Do Until Cells(ActiveCell.Row, "J").Value = ""
    ActiveCell.Value = ActiveCell.Value + RSUP
    ActiveCell.Offset(1, 0).Activate
    Loop
End If


' Place in Advert Data
Application.ScreenUpdating = False
Call SACommit
Application.ScreenUpdating = False
' Finish Up
Application.ScreenUpdating = False
temp.Activate
Cells.ClearContents
ads.Activate
end_time = Now()
Cells(ActiveCell.Row, "O").Value = Format(end_time - start_time, "h:mm:ss")
Success = True
NoTours:
On Error Resume Next
Resume Skip
On Error GoTo 0
Skip:
ads.Activate
ActiveCell.Offset(1, 0).Activate
On Error GoTo 0


If Success = True Then
WB.Save
Range("X1").Value = ""
End If


' Update Progress Box


If ActiveCell.Row < 4 Then
Else
LastTime = Cells(ActiveCell.Row, "O").End(xlUp).Value
End If
TotTime = Format(Now() - mt.Range("F2").Value, "hh:mm:ss")
ProgBox.TotalTime.Caption = TotTime
ProgBox.LastSelect.Caption = Format(LastTime, "hh:mm:ss")
ProgBox.Repaint


Loop ' Main Loop


Unload ProgBox
Application.ScreenUpdating = True


MsgBox "Super Automation Done!"


End Sub

Super Automation Module (I know, that's confusing) The Super Automation code is within a control panel userform, and the Super Automation MODULE is where the products get ranked.
Code: 
Sub SuperAutomation()

Dim Maxtours As Long
wbyr = 2019
nwbyr = 2020
Set ads = Worksheets("AdSelect")
Set atm = Worksheets("ATM")
Set am = Worksheets("AM")
Set AMPD = Worksheets("AMPD")
Set remcap = Worksheets("CAP")
Set adstemp = Worksheets("Temp")


If adstemp.Range("A6").Value = "Just Go" Then
JG = True
Omega = False
Else
Omega = True
JG = False
End If


Maxtours = adstemp.Range("A5").Value


adstemp.Activate
PaperName = Range("A2").Value
templatesize = Range("A3").Value
WCD = ads.Range("A1").Value
lastrowADST = Cells(Rows.Count, "A").End(xlUp).Row


'Open Automation Hub


Application.ScreenUpdating = False


ahopen = False


If ahopen <> True Then
Application.DisplayAlerts = False
Set ah = Workbooks.Open("H:\Sales\Regional Press Selections\" & wbyr & "\Automation Hub.xlsx", False, False)
Application.DisplayAlerts = True
Else
ah.Activate
End If


Set Sp = Worksheets("Start Page")
Set tw1 = Worksheets("Tour Weighting 1")
Set tw2 = Worksheets("Tour Weighting 2")
Set ar = Worksheets("Ad Recency")
Set roi = Worksheets("ROI")
Set cap = Worksheets("Capacity")
Set lt = Worksheets("Lead Time")
Set fr = Worksheets("Frequency")
Set dv = Worksheets("Discount Value")
Set dl = Worksheets("Discount Lead")
Set *** = Worksheets("Assorted")


On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Temp").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add.Name = "Temp"
Set temp = Worksheets("Temp")
Application.ScreenUpdating = False


'Populate Start Page


Sp.Activate
Cells.EntireColumn.Hidden = False
Cells.EntireRow.Hidden = False
On Error Resume Next
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
On Error GoTo 0


Application.ScreenUpdating = False
Range("3:3", Range("3:3").End(xlDown)).Delete xlUp
Range("3:3", Range("3:3").End(xlDown)).Delete xlUp
Range("A3").Activate


adstemp.Range("A12:A" & lastrowADST).Copy Sp.Range("E3")
adstemp.Range("B12:B" & lastrowADST).Copy Sp.Range("F3")
adstemp.Range("C12:C" & lastrowADST).Copy Sp.Range("H3")
adstemp.Range("D12:D" & lastrowADST).Copy Sp.Range("K3")
Lastrow = Cells(Rows.Count, "E").End(xlUp).Row


Range("A3:A" & Lastrow).Value = PaperName
Range("B3:B" & Lastrow).Value = WCD
Range("C3:C" & Lastrow).Value = templatesize
Range("C:C").NumberFormat = "m/d/yyyy"
Range("H:H").NumberFormat = "m/d/yyyy"


Range("I3:I" & Lastrow).FormulaR1C1 = "=LEFT(RC5,1)"


Range("F3:K" & Lastrow).Copy
Range("F3").PasteSpecial xlPasteValues
Range("A3").Select


Range("H:H").NumberFormat = "dd/mm/yyyy"
Range("K:L").NumberFormat = "£#,##0.00"
Application.ScreenUpdating = False


' Remove blank lines


Range("A3").Activate


Do Until Cells(ActiveCell.Row, "A").Value = ""
    If Cells(ActiveCell.Row, "H").Value = "" Then
        ActiveCell.EntireRow.Delete
        ActiveCell.Offset(-1, 0).Activate
    End If
    ActiveCell.Offset(1, 0).Activate
Loop


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set a = Workbooks.Open("H:\Sales\Regional Press Selections\" & wbyr & "\Advert Data " & wbyr & ".csv", False, True)
Application.DisplayAlerts = True
Application.ScreenUpdating = False


Sp.Activate


Range("M3:M" & Lastrow).FormulaR1C1 = "=IFERROR(INDEX('[" & ads.Parent.Name & "]AMPD'!C3,MATCH(RC1,'[" & ads.Parent.Name & "]AMPD'!C5,0),FALSE),"""")"


Range("M3:M" & Lastrow).Copy
Range("M3").PasteSpecial xlPasteValues


a.Activate
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Range("Y2:Y" & Lastrow).FormulaR1C1 = "=COUNTIFS('[Automation Hub.xlsx]Start Page'!C5,RC1)"
Range("X2:X" & Lastrow).FormulaR1C1 = "=IFERROR(INDEX('[" & ads.Parent.Name & "]AMPD'!C3,MATCH(RC14,'[" & ads.Parent.Name & "]AMPD'!C5,0),FALSE),"""")"
Range("L:L").NumberFormat = "dd/mm/yyyy"
Range("X2:Y" & Lastrow).Copy
Range("X2").PasteSpecial xlPasteValues


Sp.Activate
Lastrow = Cells(Rows.Count, "E").End(xlUp).Row


Range("O3:O" & Lastrow).FormulaR1C1 = "=COUNTIFS('" & a.Name & "'!C1,RC5,'" & a.Name & "'!C14,RC1)"
Range("P3:P" & Lastrow).FormulaR1C1 = "=COUNTIFS('" & a.Name & "'!C24,RC13,'" & a.Name & "'!C1,RC5,'" & a.Name & "'!C12,RC2)"
Range("R3:R" & Lastrow).FormulaR1C1 = "=COUNTIFS('" & a.Name & "'!C1,RC5,'" & a.Name & "'!C12,RC2)"
Range("O3:R" & Lastrow).Copy
Range("O3").PasteSpecial xlPasteValues


ThisYear:


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wr = Workbooks.Open("H:\Sales\Reporting\New Weekly Report\Templates\" & wbyr & " Weekly Report Master.xlsm", False, True)
Application.DisplayAlerts = True
On Error GoTo 0
Sp.Activate
Range("G3:G" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(VLOOKUP(RC5,'[" & wbyr & " Weekly Report Master.xlsm]TM Data'!C1:C8,8,FALSE),'[" & wbyr & " Weekly Report Master.xlsm]Categories & Products'!C6:C9,4,FALSE),"""")"
Application.ScreenUpdating = False


AllGood:


Range("G3:G" & Lastrow).Copy
Range("G3").PasteSpecial xlPasteValues


Application.ScreenUpdating = False
Application.DisplayAlerts = False
wr.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = False


'Sister paper = future dev


Range("A3").Activate


Range("Q3:Q" & Lastrow).Value = 0
Range("AJ3:AJ" & Lastrow).Value = 0


Sp.Activate
Range("J3:J" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-5],'[" & ads.Parent.Name & "]CAP'!C1:C5,5,0),0)"
Range("J3:J" & Lastrow).Copy
Range("J3").PasteSpecial xlPasteValues




Range("A3").Activate


' Remaining Capacity Points


Do Until Cells(ActiveCell.Row, "A").Value = ""
rcap = Cells(ActiveCell.Row, "J").Value
cap.Activate
pnt = 0
Range("A3").Activate
    Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "A").Value <= CInt(rcap) And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= CInt(rcap) Then
        pnt = Cells(ActiveCell.Row, "B").Value
        Exit Do
        End If
    ActiveCell.Offset(1, 0).Activate
    Loop
Sp.Activate
Cells(ActiveCell.Row, "AF").Value = pnt
ActiveCell.Offset(1, 0).Activate
Loop


'Template restrictions - temporary logic


Sp.Activate
Range("A3").Activate


    If InStr(Cells(ActiveCell.Row, "C").Value, "EU") > 0 Then
    Range("D3:D" & Lastrow).Value = "3,5,6,9,Z"
    Else
    Range("D3:D" & Lastrow).Value = "1,2,4,7,8,E,F,L"
    End If


'Add other points which can be determined at this stage


'Manual Weighting
Range("Y3:Y" & Lastrow).FormulaR1C1 = "=SUMIFS('Tour Weighting 1'!C3,'Tour Weighting 1'!C1,RC5)+SUMIFS('Tour Weighting 2'!C2,'Tour Weighting 2'!C1,RC6)"
'PAper Frequency
Range("AG3:AG" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(IF(RC15>10,10,RC15),Frequency!C1:C2,2,FALSE),0)"
' Week Frequency
Range("AI3:AI" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(IF(RC18>10,10,RC18),Frequency!C1:C2,2,FALSE),0)"
Range("Y3:AI" & Lastrow).Copy
Range("Y3").PasteSpecial xlPasteValues


***.Activate
nyt = Range("B5").Value
nyf = Range("C5").Value
tbt = Range("B7").Value
tbf = Range("C7").Value
det = Range("B10").Value
def = Range("C10").Value
Sp.Activate
Range("AH3").Activate


Do Until Cells(ActiveCell.Row, "A").Value = ""
    If Year(Cells(ActiveCell.Row, "H").Value) = wbyr Then
    Cells(ActiveCell.Row, "AK").Value = nyf
    Else
    Cells(ActiveCell.Row, "AK").Value = nyt
    End If
    If Cells(ActiveCell.Row, "D").Value <> "N/A" And Not InStr(Cells(ActiveCell.Row, "D").Value, CStr(Cells(ActiveCell.Row, "I").Value)) > 0 Then
    Cells(ActiveCell.Row, "AD").Value = tbt
    Else
    Cells(ActiveCell.Row, "AD").Value = tbf
    End If
    If Cells(ActiveCell.Row, "P").Value > 0 Then
    Cells(ActiveCell.Row, "AH").Value = det
    Else
    Cells(ActiveCell.Row, "AH").Value = def
    End If
ActiveCell.Offset(1, 0).Activate
Loop


'Last used


temp.Activate
Range("A1").Value = "Tourno"
Range("B1").Value = "Last Used"
Range("A2").Activate
a.Activate
Range("A2").Activate
run2 = False


Do Until Cells(ActiveCell.Row, "A").Value = ""
    If Cells(ActiveCell.Row, "Y").Value > 0 Then
    ctno = Cells(ActiveCell.Row, "A").Value
    luse = 0
        Do Until Cells(ActiveCell.Row, "A").Value <> ctno
            If Cells(ActiveCell.Row, "N").Value = PaperName And Cells(ActiveCell.Row, "L").Value > luse Then
            luse = Cells(ActiveCell.Row, "L").Value
            End If
        ActiveCell.Offset(1, 0).Activate
        Loop
    temp.Activate
    Cells(ActiveCell.Row, "A").Value = ctno
        If luse = 0 Then
        Cells(ActiveCell.Row, "B").Value = "N/A"
        Else
        Cells(ActiveCell.Row, "B").Value = luse
        End If
    ActiveCell.Offset(1, 0).Activate
    a.Activate
    End If
ActiveCell.Offset(1, 0).Activate
Loop


temp.Activate
Range("A2").Activate


Do Until Cells(ActiveCell.Row, "A").Value = ""
    If Cells(ActiveCell.Row, "B").Value = "N/A" Then
    ActiveCell.EntireRow.Delete xlUp
    Else
    ActiveCell.Offset(1, 0).Activate
    End If
Loop


Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
If Lastrow > 2 Then
temp.Sort.SortFields.Clear
temp.Sort.SortFields.Add Key:=Range("B2:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With temp.Sort
    .SetRange Range("A2:B" & Lastrow)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End If


Sp.Activate
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Range("N3:N" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(RC5,Temp!C1:C2,2,FALSE),""N/A"")"
Range("N3:N" & Lastrow).Copy
Range("N3").PasteSpecial xlPasteValues
Range("A3").Activate


Do Until Cells(ActiveCell.Row, "A").Value = ""
    If Cells(ActiveCell.Row, "N").Value = "N/A" Then
    wks = 999
    Else
    wks = Round((Cells(ActiveCell.Row, "B").Value - Cells(ActiveCell.Row, "N").Value) / 7, 0)
    End If
ar.Activate
Range("A3").Activate
    Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "A").Value = wks Or Cells(ActiveCell.Offset(1, 0).Row, "A").Value = "" Then
        pnt = Cells(ActiveCell.Row, "B").Value
        Exit Do
        End If
    ActiveCell.Offset(1, 0).Activate
    Loop
Sp.Activate
Cells(ActiveCell.Row, "AB").Value = pnt
ActiveCell.Offset(1, 0).Activate
Loop


Sp.Activate
Range("N:N").NumberFormat = "dd/mm/yyyy"


Application.ScreenUpdating = False
Application.DisplayAlerts = False
a.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = False


temp.Activate
Cells.ClearContents


'sp.Activate
Range("A3").Activate
'Add discounted price when blank


Do Until Cells(ActiveCell.Row, "A").Value = ""
lt = Round((Cells(ActiveCell.Row, "H").Value - Cells(ActiveCell.Row, "B").Value) / 7, 0)
    If Cells(ActiveCell.Row, "L").Value = "" Then
    fp = Cells(ActiveCell.Row, "K").Value
    dval = 0
        Select Case Cells(ActiveCell.Row, "I").Value
        Case "5", "7", "8", "9"
        Case Else
        dl.Activate
        Range("A3").Activate
            Do Until (Cells(ActiveCell.Row, "A").Value <= lt And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= lt) Or Cells(ActiveCell.Row, "A").Value = ""
            ActiveCell.Offset(1, 0).Activate
            Loop
            If Cells(ActiveCell.Row, "A").Value = "" Then
                If lt > Cells(ActiveCell.Offset(-1, 0).Row, "A").Value Then
                    If Cells(ActiveCell.Offset(-1, 0).Row, "B").Value = "Y" Then
                    discapp = True
                    Else
                    discapp = False
                    End If
                Else
                discapp = False
                End If
            Else
                If Cells(ActiveCell.Row, "B").Value = "Y" Then
                discapp = True
                Else
                discapp = False
                End If
            End If
            If discapp = True Then
            dv.Activate
            Range("A3").Activate
                Do Until Cells(ActiveCell.Row, "A").Value = ""
                    If Cells(ActiveCell.Row, "A").Value <= fp And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= fp Then
                    dval = Cells(ActiveCell.Row, "B").Value
                    Exit Do
                    End If
                ActiveCell.Offset(1, 0).Activate
                Loop
            Else
            dval = 0
            End If
        Sp.Activate
        End Select
    Cells(ActiveCell.Row, "L").Value = Cells(ActiveCell.Row, "K").Value - dval
    End If
ActiveCell.Offset(1, 0).Activate
Loop


Sp.Activate
Range("A3").Activate


'Open Regional Press Report - to change to wbyr in Feb


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set rpr = Workbooks.Open("H:\Sales\Reporting\Regional Press Reporting\Regional Press Reporting " & wbyr & ".xlsm", False, True)
Application.DisplayAlerts = True
Application.ScreenUpdating = False


Set ps = Worksheets("Price Summary")
Set lts = Worksheets("Lead Time Summary")
Set tns = Worksheets("Tour Name Summary")
Set ds = Worksheets("Destination Summary")


***.Activate
nubt = Range("B9").Value
nubf = Range("C9").Value


Sp.Activate
Range("A3").Activate


Do Until Cells(ActiveCell.Row, "A").Value = ""
pname = Cells(ActiveCell.Row, "F").Value
sname = Cells(ActiveCell.Row, "G").Value
dp = Cells(ActiveCell.Row, "L").Value
lt = Round((Cells(ActiveCell.Row, "H").Value - Cells(ActiveCell.Row, "B").Value) / 7, 0)
roi1 = 0
roi2 = 0
'roi3 = 0
use1 = 0
tns.Activate
Range("A5").Activate
    Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "A").Value = pname Then
            Select Case rop
            Case True
                Select Case JG
                Case True
                    If Cells(ActiveCell.Row, "I").Value = "" Then
                    roi1 = 0
                    Else
                    roi1 = Cells(ActiveCell.Row, "I").Value
                    End If
                use1 = Cells(ActiveCell.Row, "B").Value
                Case Else
                    If Cells(ActiveCell.Row, "Y").Value = "" Then
                    roi1 = 0
                    Else
                    roi1 = Cells(ActiveCell.Row, "YI").Value
                    End If
                use1 = Cells(ActiveCell.Row, "R").Value
                End Select
            Case Else
                Select Case JG
                Case True
                    If Cells(ActiveCell.Row, "Q").Value = "" Then
                    roi1 = 0
                    Else
                    roi1 = Cells(ActiveCell.Row, "Q").Value
                    End If
                use1 = Cells(ActiveCell.Row, "J").Value
                Case Else
                    If Cells(ActiveCell.Row, "AG").Value = "" Then
                    roi1 = 0
                    Else
                    roi1 = Cells(ActiveCell.Row, "AG").Value
                    End If
                use1 = Cells(ActiveCell.Row, "Z").Value
                End Select
            End Select
        Exit Do
        End If
    ActiveCell.Offset(1, 0).Activate
    Loop
    If roi1 = 0 And use1 = 0 Then
    ds.Activate
    Range("A4").Activate
        Do Until Cells(ActiveCell.Row, "A").Value = ""
            If Cells(ActiveCell.Row, "A").Value = sname Then
                Select Case rop
                Case True
                    Select Case JG
                    Case True
                        If Cells(ActiveCell.Row, "I").Value = "" Then
                        roi1 = 0
                        Else
                        roi1 = Cells(ActiveCell.Row, "I").Value
                        End If
                    use1 = Cells(ActiveCell.Row, "B").Value
                    Case Else
                        If Cells(ActiveCell.Row, "Y").Value = "" Then
                        roi1 = 0
                        Else
                        roi1 = Cells(ActiveCell.Row, "YI").Value
                        End If
                    use1 = Cells(ActiveCell.Row, "R").Value
                    End Select
                Case Else
                    Select Case JG
                    Case True
                        If Cells(ActiveCell.Row, "Q").Value = "" Then
                        roi1 = 0
                        Else
                        roi1 = Cells(ActiveCell.Row, "Q").Value
                        End If
                    use1 = Cells(ActiveCell.Row, "J").Value
                    Case Else
                        If Cells(ActiveCell.Row, "AG").Value = "" Then
                        roi1 = 0
                        Else
                        roi1 = Cells(ActiveCell.Row, "AG").Value
                        End If
                    use1 = Cells(ActiveCell.Row, "Z").Value
                    End Select
                End Select
            End If
        ActiveCell.Offset(1, 0).Activate
        Loop
    End If
'Below: making the assumption the price brackets in the RPR will not change!
ps.Activate
Range("A5").Activate
    If dp < 100 Then
    Range("A5").Activate
    GoTo FoundROI
    End If
    If dp > 999 Then
    Range("A25").Activate
    GoTo FoundROI
    End If
On Error GoTo NextRow
    For x = 5 To 24
        If CInt(Mid(Cells(ActiveCell.Row, "A").Value, 2, 3)) <= dp And CInt(Mid(Cells(ActiveCell.Offset(1, 0).Row, "A").Value, 2, 3)) >= dp Then
FoundROI:
            Select Case rop
            Case True
                Select Case JG
                Case True
                    If Cells(ActiveCell.Row, "I").Value = "" Then
                    roi2 = 0
                    Else
                    roi2 = Cells(ActiveCell.Row, "I").Value
                    End If
                Case Else
                    If Cells(ActiveCell.Row, "Y").Value = "" Then
                    roi2 = 0
                    Else
                    roi2 = Cells(ActiveCell.Row, "Y").Value
                    End If
                End Select
            Case Else
                Select Case JG
                Case True
                    If Cells(ActiveCell.Row, "Q").Value = "" Then
                    roi2 = 0
                    Else
                    roi2 = Cells(ActiveCell.Row, "Q").Value
                    End If
                Case Else
                    If Cells(ActiveCell.Row, "AG").Value = "" Then
                    roi2 = 0
                    Else
                    roi2 = Cells(ActiveCell.Row, "AG").Value
                    End If
                End Select
            End Select
        Exit For
        End If
NextRow:
    ActiveCell.Offset(1, 0).Activate
    Next x
On Error GoTo 0
roi.Activate
roiw1 = 0
roiw2 = 0
' roiw3 = 0  !@!
    For x = 1 To 2   'was 1 to 3
    Range("A3").Activate
        Do Until Cells(ActiveCell.Row, "A").Value = ""
            Select Case x
            Case 1
                If Cells(ActiveCell.Row, "A").Value <= roi1 And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= roi1 Then
                roiw1 = Cells(ActiveCell.Row, "B").Value
                Exit Do
                End If
            Case 2
                If Cells(ActiveCell.Row, "A").Value <= roi2 And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= roi2 Then
                roiw2 = Cells(ActiveCell.Row, "B").Value
                Exit Do
                End If
'            Case 3
'                If Cells(ActiveCell.Row, "A").Value <= roi3 And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= roi3 Then
'                roiw3 = Cells(ActiveCell.Row, "B").Value
'                Exit Do
'                End If
            End Select
        ActiveCell.Offset(1, 0).Activate
        Loop
    Next x
Sp.Activate
Cells(ActiveCell.Row, "S").Value = roi1
Cells(ActiveCell.Row, "T").Value = roi2
'Cells(ActiveCell.Row, "U").Value = roi3
Cells(ActiveCell.Row, "X").Value = roiw1
Cells(ActiveCell.Row, "AC").Value = roiw2
'Cells(ActiveCell.Row, "AE").Value = roiw3  !@!


' New Lead Time Calculation


If Cells(ActiveCell.Row, "I").Value = "3" Or Cells(ActiveCell.Row, "I").Value = "6" Then
    Cells(ActiveCell.Row, "U").FormulaR1C1 = "=ROUNDUP((RC[-13]-RC[-19])/7,0)"
    Cells(ActiveCell.Row, "U").Value = Cells(ActiveCell.Row, "U").Value
    Cells(ActiveCell.Row, "AE").FormulaR1C1 = "=VLOOKUP(ROUNDUP((RC[-23]-RC[-29])/7,0),'Lead Time'!C[-27]:C[-26],2,0)"
    Cells(ActiveCell.Row, "AE").Value = Cells(ActiveCell.Row, "AE").Value
    Else
    Cells(ActiveCell.Row, "U").FormulaR1C1 = "=ROUNDUP((RC[-13]-RC[-19])/7,0)"
    Cells(ActiveCell.Row, "U").Value = Cells(ActiveCell.Row, "U").Value
    Cells(ActiveCell.Row, "AE").FormulaR1C1 = "=VLOOKUP(ROUNDUP((RC[-23]-RC[-29])/7,0),'Lead Time'!C[-30]:C[-29],2,0)"
    Cells(ActiveCell.Row, "AE").Value = Cells(ActiveCell.Row, "AE").Value
End If
   
   If use1 = 0 And Cells(ActiveCell.Row, "R").Value < 5 Then
    Cells(ActiveCell.Row, "AM").Value = nubt
    Else
    Cells(ActiveCell.Row, "AM").Value = nubf
    End If
ActiveCell.Offset(1, 0).Activate
Loop


Application.ScreenUpdating = False
Application.DisplayAlerts = False
rpr.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = False


'First summary and ranking


Sp.Activate
Range("V3:V" & Lastrow).FormulaR1C1 = "=SUM(RC24:RC39)"
Range("W3:W" & Lastrow).FormulaR1C1 = "=RANK(RC22,C22)"
Range("V3:W" & Lastrow).Copy
Range("V3").PasteSpecial xlPasteValues


'Diversity check, and second (and third etc.) ranking


***.Activate
div1t = Range("B3").Value
div1f = Range("C3").Value
div2t = Range("B4").Value
div2f = Range("C4").Value
pt = Range("B8").Value
pf = Range("C8").Value


'Sort by ranking


Sp.Activate
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Sp.Sort.SortFields.Clear
    Sp.Sort.SortFields.Add Key:=Range("W3:W" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With Sp.Sort
        .SetRange Range("A3:AM" & Lastrow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
crow = 0


' Diversity Checks and re-ranking


For x = 1 To Maxtours
Range("A3").Activate
    Do Until (Cells(ActiveCell.Row, "W").Value >= x And ActiveCell.Row > crow) Or Cells(ActiveCell.Row, "W").Value = x Or Cells(ActiveCell.Row, "A").Value = ""
    ActiveCell.Offset(1, 0).Activate
    Loop
    If Cells(ActiveCell.Row, "A").Value <> "" Then
    crow = ActiveCell.Row
    tname = Cells(ActiveCell.Row, "F").Value
    sname = Cells(ActiveCell.Row, "G").Value
    tdig = Cells(ActiveCell.Row, "I").Value
    dcod = Mid(Cells(ActiveCell.Row, "E").Value, 2, 2)
    dp = Cells(ActiveCell.Row, "K").Value
    Cells(ActiveCell.Row, "Z").Value = 100
    Cells(ActiveCell.Row, "AA").Value = 100
    Cells(ActiveCell.Row, "AL").Value = pt
    ActiveCell.Offset(1, 0).Activate
'Range("A3").Activate
        Do Until Cells(ActiveCell.Row, "A").Value = ""
            If Cells(ActiveCell.Row, "Z").Value = 0 And Cells(ActiveCell.Row, "AA").Value = 0 Then
                If (ActiveCell.Row <> crow Or (ActiveCell.Row < crow And Cells(ActiveCell.Row, "W").Value >= x)) Then
                    If Cells(ActiveCell.Row, "F").Value = tname Or Cells(ActiveCell.Row, "G").Value = sname Then
                    Cells(ActiveCell.Row, "Z").Value = div1t
                    Else
                    Cells(ActiveCell.Row, "Z").Value = div1f
                    End If
                    If Mid(Cells(ActiveCell.Row, "E").Value, 2, 2) = dcod And Left(Cells(ActiveCell.Row, "E").Value, 1) <> "E" Then
                    Cells(ActiveCell.Row, "AA").Value = div2t
                    Else
                    Cells(ActiveCell.Row, "AA").Value = div2f
                    End If
                    If Cells(ActiveCell.Row, "K").Value >= (dp * 0.66) And Cells(ActiveCell.Row, "K").Value <= (dp * 1.33) Then
                    Cells(ActiveCell.Row, "AL").Value = pt
                    Else
                    Cells(ActiveCell.Row, "AL").Value = pf
                    End If
                Else
                Cells(ActiveCell.Row, "Z").Value = div1f
                Cells(ActiveCell.Row, "AA").Value = div2f
                Cells(ActiveCell.Row, "AL").Value = pt
                End If
            End If
        ActiveCell.Offset(1, 0).Activate
        Loop
    Range("V3:V" & Lastrow).FormulaR1C1 = "=SUM(RC24:RC39)"
    Range("W3:W" & Lastrow).FormulaR1C1 = "=RANK(RC22,C22)"
    Range("V3:W" & Lastrow).Copy
    Range("V3").PasteSpecial xlPasteValues
    Sp.Sort.SortFields.Clear
    Sp.Sort.SortFields.Add Key:=Range("W3:W" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With Sp.Sort
        .SetRange Range("A3:AM" & Lastrow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    End If
Next x


Range("A3").Activate


On Error GoTo NoSave


Sp.Copy
Range("1:1").Delete xlUp




If rop = True Then
newdir = "H:\Sales\Regional Press Selections\" & wbyr & "\Automation Files\ROP\wc " & Format(DateValue(WCD), "yyyy-mm-dd")
Else
newdir = "H:\Sales\Regional Press Selections\" & wbyr & "\Automation Files\RT\wc " & Format(DateValue(WCD), "yyyy-mm-dd")
End If


If Dir(newdir, vbDirectory) = vbNullString Then
On Error Resume Next
MkDir newdir
On Error GoTo 0
End If


'nsname = Replace(PaperName, "/", "") & " - " & PaperName !@!


nsname = Replace(PaperName, "/", "&")


tsize = adstemp.Range("A4").Value


Set n = ActiveWorkbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'n.SaveAs filename:=newdir & "\" & nsname & " - Super - " & ".csv", FileFormat:=xlCSV, CreateBackup:=False
If adstemp.Range("A6").Value = "Just Go" Then
n.SaveAs filename:=newdir & "\" & nsname & " - Super - " & tsize & " JG" & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Else
n.SaveAs filename:=newdir & "\" & nsname & " - Super - " & tsize & " OM" & ".csv", FileFormat:=xlCSV, CreateBackup:=False
End If
n.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = False




NoSave:
Resume Skip
Skip:
' Bring results back to adstemp
Range("E3:E" & Lastrow).Copy adstemp.Range("H12")
Range("F3:F" & Lastrow).Copy adstemp.Range("I12")
Range("K3:K" & Lastrow).Copy adstemp.Range("J12")
Range("W3:W" & Lastrow).Copy adstemp.Range("K12")
Range("V3:V" & Lastrow).Copy adstemp.Range("L12")
Range("Y3:Y" & Lastrow).Copy adstemp.Range("M12")


Application.EnableEvents = True
Application.DisplayAlerts = False


If ah.ReadOnly = False Then
ah.Close True
Else
ah.Close False
End If




Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub
 
Last edited:
Sort by date Sort by votes
Hi, just to clarify what is meant by "which requires me to close down the sheets it opened" ... sheets are in a workbook. You don't close sheets, just the workbook. Is there more than one (or more than two) workbooks? Or just one workbook with lots of sheets in it? Or do you mean new sheets being created? Don't forget my note from post number 2 -- "One suggestions is that as a rule with a long running macro I would avoid copying, deleting, or adding worksheets to a workbook that is in use the whole time the code is running." I don't recall the precise details but that used to be a known bug years back.
 
Upvote 0

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Hi,

So the workbook the macro is ran from is "Super Automation", when running it selects the first title, "Alpha Chronicle" - details are brought into the temp sheet and some variables are set, for example I want this feature to have an EU template with Air products being selected, I need 2 different ads to run in this feature (A feature is the space on the page which an ad runs in)

From there, the Advert Data is loaded, a .csv file with over 20,000 rows of information from column A to column W.

I apply a series of autofilter criteria to give a list of products I that have an applicable criteria (air products with some matching location information)

The Advert Data is then closed and "Super Automation" the MODULE is called (which I know is confusing as the workbook name is Super Automation)

In this module some criteria are declared and then the Workbook Automation Hub is opened (which has about 20 worksheets) - I've made sure all these sheets now have a unique and distinct name, so temp can't apply to both the temp sheet in Super Automation and the temp sheet in Automation Hub.

This is where the crash is happening, right at the start of the macro when it loads the Automation Hub.
 
Upvote 0
I found a line of code in your code that uses a goto to jump inside an if block inside a for block. I'm not sure that's possible - maybe it won't crash but you probably should not do that (if nothing else the variables controlling the for loop will be undefined at that point and no way of knowing how many loops will run).

Code: 
'Below: making the assumption the price brackets in the RPR will not change!
ps.Activate
Range("A5").Activate
    If dp < 100 Then
    Range("A5").Activate
    GoTo FoundROI
    End If
    If dp > 999 Then
    Range("A25").Activate
    [COLOR="#FF0000"]GoTo FoundROI[/COLOR]
    End If
On Error GoTo NextRow
    For x = 5 To 24
        If CInt(Mid(Cells(ActiveCell.Row, "A").Value, 2, 3)) <= dp And CInt(Mid(Cells(ActiveCell.Offset(1, 0).Row, "A").Value, 2, 3)) >= dp Then
[COLOR="#FF0000"][COLOR="#FF0000"]FoundROI:[/COLOR][/COLOR]


Note: Couldn't find anything else that was obviously wrong. But from a general standpoint I would want to rewrite to remove all the active cell and activesheet stuff. Can't say that's a cause of crashes - just a possible cause of problems generally. It would seems useful to break up the program into smaller parts as well, but also not something that causes errors, just makes it harder to maintain, so can't really say that's your current issue. Not 100% sure yet but it might be nice if you could have your iterations really clean - 100% finished on each iteration, so every new loop is really like a completely fresh start.
 
Last edited:
Upvote 0
It seems to crash much less with "Break on all errors" selected, rather than "break on unhandled errors"

Which is odd, I still get repeated and random silent halts on the macro.
 
Upvote 0
You must log in or register to reply here.

Similar threads

SlinkRN
  • Solved
Handling Multiple Errors within one loop
Replies
7
Views
251
SlinkRN
SlinkRN
P
  • Solved
Slow Macro
Replies
3
Views
403
Philip1957
P
M
  • Question Question
Using VBA code in a protected excel sheet
Replies
2
Views
512
MagicCarpet
M
U
  • Question Question
Text Value from Textbox to Integer
Replies
1
Views
333
Kaper
Kaper
J
  • Question Question
VBA Code to Add Rows is slowing down
Replies
5
Views
989
JayB0730
J

Forum statistics

Threads
1,223,886
Messages
6,175,190
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top