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

 

[RoryA]

If you need it to be False if not all of those things are false, you could use:

Coach = (Air = False and SD = False and Rail = False)

instead of an If statement.

 

[RockandGrohl]

That's pretty juicy, thanks. Will make the change.

I'm actually reverting all changes made circa 16th Sept - the sheet has just collapsed and is telling me things are "selected" but it's not writing the selections to the Advert Data csv, so I'm going back to a much earlier version from around the 4th September.

So back to the drawing board.

 

[RockandGrohl]

Here's a thought guys.

Say I have a loop in my main sub, and then it calls new subs for each of the various procedures I want to run.

Currently, I am skipping portions of code when I'm encountering an expected error, but I think this is manifesting itself negatively in other areas.

If I'm running a loop and I call a new sub, if I encounter an expected error and instead hit "Exit sub", will the sub close and the loop will resume, going to the next part?

Because then I could just shut down steps 6, 7 and 8 if step 5 was not completed.

 

[RoryA]

It would resume at the next line in the calling code. If you don't want that, you can either use error handling in the main sub, or make the called subs into functions that return values indicating whether they completed successfully or not.

 

[RockandGrohl]

So I think a large proportion of errors are when "Automation Hub" is loaded.

We were getting serious problems with these sheet before, where it would completely corrupt and crash Excel totally upon opening, we had to retrieve older, working versions of the file quite regularly - every few months or so.

A month ago I identified that Automation Hub may be problematic and I stripped all code away from the file, so it was just a plain .xlsx file.

I've just had a thought, what if the file itself is just broken in some unrecoverable way - now that it's just an .xlsx file, what if I just create an entirely new workbook, copy the content over and then use that instead.

I haven't tried it out yet as we start selections on a Tuesday, but an encouraging sign is that the new file is 57kb, but the old one is 299kb - 6 times smaller, even though the content is identical. So maybe there was some broken code lodged in the file, all jammed up, and was causing the errors.

Will be interesting this week to see if it crashes again.

 

[xenou]

I'll stay tuned.

 

[RockandGrohl]

Nah, still got Automation Error

 

[RockandGrohl]

Hoping now that doing a "DoEvents" right as the Automation Hub gives the macro time to breathe - I'm still getting issues though where the variable that writes to cell A8 in Adstemp doesn't seem to be fully resetting, so "coach" is being written where it really should be writing "Air" etc.

 

[xenou]

How many workbooks are involved when this is running? What other data sources (?) are involved - is there a database or something else? Worried that you aren't keeping track of workbooks very well since there a lot of dependence on ActiveCell and ActiveWorkbook (which is inherently dangerous). I don't recommend using DoEvents unless it is for a specific reason (it shouldn't be necessary in general but in some cases it is needed I guess).

 

[RockandGrohl]

Hi mate,

No other data sources involved, no external databases or anything else to connect to. The various supplementary sheets are all set worksheets upon opening.

The problem still centres around opening the Automation Hub, though I will state that after putting DoEvents in, I didn't get a hard-crash for the remaining 200 or so iterations, however the macro did unexpectedly stop a few times (which required me to close down the sheets it opened and then restart the macro from the main file)