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

[RockandGrohl]

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

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.

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

 

[xenou]

Hi,
I guess I can only suggest you start doing some logging to narrow down the problem.

perhaps think in terms of checkpointing
1st run started, 1st part complete, 2nd part complete, 3rd part complete
2nd run started, 1st part complete, 2nd part complete, 3rd part complete
3rd run started, 1st part complete, 2nd part complete, 3rd part complete
...

this could help with narrowing down the place where you are crashing at runtime (or worst case, confirming it can happen anywhere).

I would for instance just create a simple logging function that my code can access from anywhere and then log messages (with timestamps) to a log file.


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.
So I'd prefer to change this:

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")

Instead just:

Worksheets("Temp").Cells.Clear

If you want to put that worksheet into another workbook then "copy" it rather than "move" it.

 

[RockandGrohl]

Hi, I've started doing the logging now and have made the other change you suggested.

With the logging, I'm having to WB.save after every log, because when Excel crashes it obviously wipes out any progress made in logging since the last step. This has unfortunately doubled my iteration time but hopefully I crash today a few times and can nail down where in the Automation Hub it's happening.

 

[RockandGrohl]

Since logging I am 134/732 ads in and have had three errors.

One has been an Automation error and two have been silent stops - where the code just stops running.

All three have been at the point where the Automation Hub file is opened, code below. Bear in mind this is where the code "Call SuperAutomation.SuperAutomation" begins at the end of the first block of code.

'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

I'm setting the displayalerts flag to true to see if I get an error.


Got another error now, this time a bit further on in the loop, when it opens the Regional Press Report.

 

[xenou]

'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

THis code will not stop you from trying to open and open workbook. You set the variable to false, then check if it is true (which it cannot be since you just set it to false). So then it will always try to open the workbook.

in general it looks fragile because even if you tried to fix how you use this variable you are relying on being careful to always set it properly. It would be better to check for the workbook's existence as an open workbook directly or use some other scheme.

This reminds me that one reason code can seem to stop running is that a dialog box has been opened by Excel and is waiting for you to click a button ... (dialog boxes such as "hey this workbook is already open do you really want to re-open it?).

Note that you can also log to an external text file instead of in the workbook.

 

[RockandGrohl]

This type of method is a relic of my predecessor, I think in some instances it was required to check if a high-usage workbook was open and then re-open the file, in case it was open in read-only mode.

Is there anything you can recommend to improve the reliability? It seems I have narrowed down (for now) the reason for the crashing being around the opening of workbooks. If you look back at the original post you can see the code in the second portion which was the various declarations in them, is there anything I've missed? Why on earth does it crash some times and not others?

 

[xenou]

Many of the open workbook statements are flawed for the same reason - the use of a true/false variable is not doing anything. I guess if the intention is to open workbooks read-only then it should be okay as long as the dialog boxes aren't interfering. You should test to confirm. As far as I know it is possible to open workbooks read-only even if they are already open (although I don't do this generally).

Anything involving "high usage" workbooks is probably going to be tricky if by high usage you mean a lot of other people are using the same workbooks. I would avoid that kind of process as a rule (shared data that needs to be accessed reliably by many people as well as by automated processes should go in data storage formats intended for shared use - in which case having multiple users opening and using a workbook is not really a good option although it can be made to work).

 

[RockandGrohl]

For the Automation Hub in particular, everything, everything that it opens is in Read-only mode as it's just parsing data that's already there. At the end of the process it copies itself to a new workbook and saves, but it's crashing intermittently before that point.

AH itself is opened Read/Write, but it's only ever opened by this Super Automation process, so nobody else uses it.

The Automation Hub used to have a lot of macros in, but I've since stripped it bare and it is now an xlsx document.

I get what you're saying about the flagging being wrong, will amend this.

 

[xenou]

Okay sounds good so far.

 

[RockandGrohl]

Okay sounds good so far.

Another problem I'm having is at the top of the main loop I determine the type of tour, and pre-emptively set everything to false.

Air = False
SD = False
Rail = False etc

I hadn't done this for Coach, but there's a bit that below that says

If Air = False and SD = False and Rail = False then Coach = True
End If

However, what I'm seeing is Rail = True, but Coach also = True, and thus Coach is being written to cell A8 which causes problems further down the line. I thought this may be because the cell was not clearing in time for the next loop, and that didn't make a difference when I attempted to fix it, so now I've gone and put Coach = False at the start along with the others, thinking the variable isn't being cleared and is retaining incorrect information for the next iteration in the loop.