Page 1 of 3 123 LastLast
Results 1 to 10 of 24

Thread: VBA Automation Error - possibly born from my complete lack of understanding with Error Handling
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Aug 2018
    Posts
    321
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    Hi all, same kind of topic again. Going to start with a top-to-bottom list of nomenclature

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

    And here's what happens:

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


    The problem:

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

    Another problem:

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

    Solutions I've tried:

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


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

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

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


    Super Automation Code
    Code:
    Private Sub SuperAuto_Click()
    
    Dim Lastrow, LastrowAD As Long, WB As Workbook
    Dim TourCopyRng As Range
    Dim DateCopyRng As Range
    Dim NameCopyRng As Range
    Dim CostCopyRng As Range
    
    
    
    
    Set ads = Worksheets("Adselect")
    Set atm = Worksheets("ATM")
    Set am = Worksheets("AM")
    Set AMPD = Worksheets("AMPD")
    Set cap = Worksheets("CAP")
    Set tod = Worksheets("TOD")
    Set mt = Worksheets("MacroTimings")
    Set tt = Worksheets("Theatre Tours")
    Set rs = Worksheets("Rail Supplement")
    Set WB = ActiveWorkbook
    wbyr = 2019
    
    
    Application.ScreenUpdating = False
    ControlPanel.Hide
    
    
    
    
    Overwrite = False
    
    
    
    
    Dim start_time, end_time
    mt.Range("F2").Value = Format(Now(), "hh:mm:ss")
    
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Temp").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Sheets.Add.Name = "Temp"
    Set temp = Worksheets("Temp")
    
    
    ads.Activate
    WCD = Range("A1").Value
    WCDV = DateValue(Range("A1").Value)
    JGtdate = WCDV + 42
    OMtdate = WCDV + 21
    
    
    Omega = False
    JG = False
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = "" ' Main Loop
    start_time = Now()
    Success = False
    
    
    If Cells(ActiveCell.Row, "G").Value = "" Then
    MsgBox "No template in current ad!"
    Exit Sub
    End If
    
    
    If Overwrite = False And Cells(ActiveCell.Row, "E").Value = "Y" Then
        GoTo Skip
    End If
    
    
    
    
    If Cells(ActiveCell.Row, "A").Value = "JP Filler Ads" Then
        Call JPFiller
        GoTo Skip
    End If
    
    
    If Overwrite = False Then
        Do Until Cells(ActiveCell.Row, "E").Value = ""
        ActiveCell.Offset(1, 0).Activate
        Loop
    End If
    
    
    PapNam = Cells(ActiveCell.Row, "A").Value
    template = Cells(ActiveCell.Row, "G").Value
    templatesize = Cells(ActiveCell.Row, "C").Value
    AdVal = Cells(ActiveCell.Row, "D").Value
    comp = Cells(ActiveCell.Row, "F").Value
    tourreq = Cells(ActiveCell.Row, "H").Value
    
    
    If InStr(Cells(ActiveCell.Row, "G").Value, "TH_") > 0 Then
    Theatre = True
    Else
    Theatre = False
    End If
    
    
    ProgBox.ProgTitleNameFront.Caption = PapNam
    ProgBox.ProgTitleNameBack.Caption = PapNam
    ProgBox.TemplateLabelFront = template
    ProgBox.TemplateLabelBack = template
    ProgBox.ProgStatusFront.Caption = Range("H1").Value
    ProgBox.ProgStatusBack.Caption = Range("H1").Value
    
    
    Load ProgBox
    With ProgBox
      .StartUpPosition = 0
      .Left = Application.Left + (0.05 * Application.Width) - (0.05 * .Width)
      .Top = Application.Top + (0.05 * Application.Height) - (0.05 * .Height)
      .Show vbModeless
    End With
    
    
    If Cells(ActiveCell.Row, "F").Value = "Just Go" Then
    JG = True
    Omega = False
    Else
    Omega = True
    JG = False
    End If
    
    
    EU = False
    Rail = False
    Air = False
    SD = False
    
    
    
    
    If Cells(ActiveCell.Row, "K").Value = "Y" Then
    EU = True
    End If
    If Cells(ActiveCell.Row, "L").Value = "Y" Then
    Rail = True
    End If
    If Cells(ActiveCell.Row, "M").Value = "Y" Then
    Air = True
    End If
    If Cells(ActiveCell.Row, "N").Value = "Y" Then
    SD = True
    End If
    If SD = False And Rail = False And Air = False Then
    Coach = True
    End If
    
    
    temp.Activate
    Cells.ClearContents
    temp.Range("A1").Value = "Paper Name"
    temp.Range("A2").Value = PapNam
    temp.Range("A3").Value = template
    temp.Range("A4").Value = templatesize
    temp.Range("A5").Value = tourreq
    temp.Range("A6").Value = comp
    temp.Range("A7").Value = AdVal
    temp.Range("B1").Value = "Primary Pickups"
    temp.Range("B2").FormulaR1C1 = "=IFERROR(VLOOKUP(RC1,AMPD!C5:C12,8,0),"""")"
    temp.Range("B2").Value = temp.Range("B2").Value
    If Coach = True Then
    temp.Range("B3").FormulaR1C1 = "=iferror(coachSTR(R2C2),"""")"
    temp.Range("B3").Value = temp.Range("B3").Value
    End If
    If Rail = True Then
    temp.Range("B3").FormulaR1C1 = "=iferror(railSTR(R2C2),"""")"
    temp.Range("B3").Value = temp.Range("B3").Value
    End If
    If Air = True Then
    temp.Range("B3").FormulaR1C1 = "=iferror(airSTR(R2C2),"""")"
    temp.Range("B3").Value = temp.Range("B3").Value
    End If
    
    
    temp.Columns("A:A").EntireColumn.AutoFit
    
    
        tempdonk = 0
        Range("B5").Activate
        Do Until tempdonk = 13
        ActiveCell.Value = "Pickup " & tempdonk + 1
        tempdonk = tempdonk + 1
        ActiveCell.Offset(0, 1).Activate
        Loop ' Naming Temp Sheet Pickups Loop
    
    
    ' Splitting Pickups
    Range("B2").Copy Range("B6")
    Range("B6").Activate
    ActiveCell.Replace What:=", ", Replacement:=",", LookAt:=xlPart, SearchOrder _
            :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    ActiveCell.TextToColumns Destination:=Range("B6"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
            :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
            Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
    
    
    ' Determining Pickup Travel Type
    
    
        Do Until Cells(6, ActiveCell.Column).Value = ""
            
            If ActiveCell Like "Flying*" Then
            ActiveCell.Offset(1, 0).Value = "Air"
            End If
            
            If ActiveCell Like "(RS)*" Then
            ActiveCell.Offset(1, 0).Value = "Rail"
            End If
            
            If ActiveCell Like "Making*" Then
            ActiveCell.Offset(1, 0).Value = "Self Drive"
            End If
            
            If ActiveCell.Offset(1, 0).Value = "" Then
            ActiveCell.Offset(1, 0).Value = "Coach"
            End If
            
            ActiveCell.Offset(0, 1).Activate
        Loop ' Pickup Travel Type Loop
    
    
    ' Adding Rail Supplement in
    
    
    If Rail = True Then
        Range("B7").Activate
        Do Until Cells(7, ActiveCell.Column).Value = ""
        If ActiveCell.Value = "Rail" Then
            ActiveCell.Offset(-3, 0).FormulaR1C1 = "=IFERROR(INDEX('Rail Supplement'!C2,MATCH(Temp!R6C,'Rail Supplement'!C1,0)),0)"
            ActiveCell.Offset(-3, 0).Value = ActiveCell.Offset(-3, 0).Value
            RSUP = ActiveCell.Offset(-3, 0).Value
        End If
        ActiveCell.Offset(0, 1).Activate
        Loop
    End If
    
    
    ' Determine what Travel type to go with for the tour
    
    
    Range("B5").Activate
    PUdonk = 0
    
    
    If Rail = True Then
    Range("A8").Value = "Rail"
        Do Until Cells(5, ActiveCell.Column).Value = ""
            If ActiveCell.Offset(2, 0).Value = "Rail" Then
            ActiveCell.Offset(1, 0).Value = "Train to London"
            PUdonk = PUdonk + 1
            ActiveCell.Offset(3, 0).Value = "PU" & PUdonk
            End If
        ActiveCell.Offset(0, 1).Activate
        Loop
    Range("B5").Activate
    PUdonk = 0
    End If
    
    
    If Air = True Then
    Range("A8").Value = "Air"
       Do Until Cells(5, ActiveCell.Column).Value = ""
            If ActiveCell.Offset(2, 0).Value = "Air" Then
            PUdonk = PUdonk + 1
            ActiveCell.Offset(3, 0).Value = "PU" & PUdonk
            End If
        ActiveCell.Offset(0, 1).Activate
        Loop
    Range("B5").Activate
    PUdonk = 0
    End If
    
    
    If SD = True Then
    Range("A8").Value = "SD"
       Do Until Cells(5, ActiveCell.Column).Value = ""
            If ActiveCell.Offset(2, 0).Value = "Self Drive" Then
            PUdonk = PUdonk + 1
            ActiveCell.Offset(3, 0).Value = "PU" & PUdonk
            End If
        ActiveCell.Offset(0, 1).Activate
        Loop
    Range("B5").Activate
    PUdonk = 0
    End If
    
    
    If Coach = True Then
    Range("A8").Value = "Coach"
       Do Until Cells(5, ActiveCell.Column).Value = ""
            If ActiveCell.Offset(2, 0).Value = "Coach" Then
            PUdonk = PUdonk + 1
            ActiveCell.Offset(3, 0).Value = "PU" & PUdonk
            End If
        ActiveCell.Offset(0, 1).Activate
        Loop
    Range("B5").Activate
    PUdonk = 0
    End If
    
    
    ' Assign pickups
    
    
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU1" Then
        PU1 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU1 = ""
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU2" Then
        PU2 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU2 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU3" Then
        PU3 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU3 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU4" Then
        PU4 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU4 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU5" Then
        PU5 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU5 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU6" Then
        PU6 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU6 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU7" Then
        PU7 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU7 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU8" Then
        PU8 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU8 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU9" Then
        PU9 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU9 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    Range("B5").Activate
    Do Until Cells(5, ActiveCell.Column) = ""
        If ActiveCell.Offset(3, 0).Value = "PU10" Then
        PU10 = ActiveCell.Offset(1, 0).Value
        Exit Do
        Else
        PU10 = "Blank"
        End If
    ActiveCell.Offset(0, 1).Activate
    Loop
    
    
    Application.DisplayAlerts = False
    
    
    temp.Range("A11").Value = "Applicable Tours"
    temp.Range("H11").Value = "Automated Tours"
    temp.Range("I11").Value = "Tour Name"
    temp.Range("J11").Value = "Price"
    temp.Range("K11").Value = "Rank"
    temp.Range("L11").Value = "Points"
    temp.Range("M11").Value = "Manual Weighting"
    adopen = False
    
    
    Application.DisplayAlerts = True
    For Each wbk In Workbooks
        If wbk.Name = "Advert Data " & wbyr & ".csv" Then
        adopen = True
        wbk.Activate
        Set ad = ActiveWorkbook
            If ad.ReadOnly = True Then
            ads.Activate
            ad.Close False
            adopen = False
            End If
        End If
    Next
    Application.DisplayAlerts = False
    
    
    If adopen <> True Then
    Application.DisplayAlerts = False
    Set ad = Workbooks.Open("H:\Sales\Regional Press Selections\" & wbyr & "\Advert Data " & wbyr & ".csv", False, True)
    Application.DisplayAlerts = True
    Else
    Application.DisplayAlerts = False
    ad.Activate
    Application.DisplayAlerts = True
    End If
    
    
    Application.DisplayAlerts = False
    
    
    LastrowAD = Cells(Rows.Count, "A").End(xlUp).Row
    
    
    Set TourCopyRng = Range("A2:A" & LastrowAD)
    Set DateCopyRng = Range("E2:E" & LastrowAD)
    Set NameCopyRng = Range("C2:C" & LastrowAD)
    Set CostCopyRng = Range("G2:G" & LastrowAD)
    
    
    
    
    Range("W2").FormulaArray = "=COUNT(SEARCH({"", " & PU1 & ","","", " & PU2 & ","","", " & PU3 & ","","", " & PU4 & ","","", " & PU5 & ",""},"", ""&RC[-14]&"",""))"
    Range("W2").Select
    Selection.AutoFill Destination:=Range("W2:W" & LastrowAD)
    
    
    
    
        
        If JG = True Then
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=5, Criteria1:=">=" & CLng(DateValue(JGtdate))     ' Tour date
        Else
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=5, Criteria1:=">=" & CLng(DateValue(OMtdate))     ' Tour date
        End If
        
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=12, Criteria1:="="                              ' Ad Week blank
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=2, Criteria1:="Active"                          ' Status Active
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=23, Criteria1:=">0"                             ' Applicable Pickup
        If JG = True Then   'Adding Theatre Tours in
        Else
        If Theatre = True Then
        Range("U2:U" & LastrowAD).FormulaR1C1 = "=IF(COUNTIF('[Super Automation.xlsm]Theatre Tours'!C1,RC[-18])>0, ""Y"","""")"
        Range("U2:U" & LastrowAD).Copy
        Range("U2").PasteSpecial xlPasteValues
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=21, Criteria1:="Y"                              ' Theatre
        Else
        Range("U2:U" & LastrowAD).FormulaR1C1 = "=IF(COUNTIF('[Super Automation.xlsm]Theatre Tours'!C1,RC[-18])>0, ""Y"","""")"
        Range("U2:U" & LastrowAD).Copy
        Range("U2").PasteSpecial xlPasteValues
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=21, Criteria1:=""                              ' Non-Theatre
        End If
        End If
        If JG = True Then
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=10, Criteria1:="<>*Omega*", Operator:=xlAnd, Criteria2:="<>*Albion*"
        Else
        ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=10, Criteria1:="*Omega*"
            If Rail = True Then
            ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=3, Criteria1:="*Rail*"
            End If
            If SD = True Then
            ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=3, Criteria1:="*h&t*"
            End If
            If Coach = True Then
            ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=3, Criteria1:="<>" & "*airport*"
            End If
            
        End If
        
        
    
    
    On Error GoTo NoTours
    TourCopyRng.SpecialCells(xlCellTypeVisible).Copy temp.Range("A12")
    NameCopyRng.SpecialCells(xlCellTypeVisible).Copy temp.Range("B12")
    DateCopyRng.SpecialCells(xlCellTypeVisible).Copy temp.Range("C12")
    CostCopyRng.SpecialCells(xlCellTypeVisible).Copy temp.Range("D12")
    ad.Close False
    On Error GoTo 0
    
    
    
    
    temp.Activate
    Tourcount = Cells(Rows.Count, "A").End(xlUp).Row - 11
    temp.Range("A10").Value = Tourcount
    
    
    ' Scrub away 3rd Party Tours
    
    
    Range("B12").Activate
    Do Until Cells(ActiveCell.Row, "B").Value = ""
        If InStr(1, ActiveCell.Value, "ripsmith", 1) > 0 Then
        Rows(ActiveCell.Row).Delete
        ActiveCell.Offset(-1, 0).Activate
        End If
        If InStr(1, ActiveCell.Value, "ravelzoo", 1) > 0 Then
        Rows(ActiveCell.Row).Delete
        ActiveCell.Offset(-1, 0).Activate
        End If
        If InStr(1, ActiveCell.Value, "owcher", 1) > 0 Then
        Rows(ActiveCell.Row).Delete
        ActiveCell.Offset(-1, 0).Activate
        End If
        If InStr(1, ActiveCell.Value, "tison", 1) > 0 Then
        Rows(ActiveCell.Row).Delete
        ActiveCell.Offset(-1, 0).Activate
        End If
        If InStr(1, ActiveCell.Value, "celolly", 1) > 0 Then
        Rows(ActiveCell.Row).Delete
        ActiveCell.Offset(-1, 0).Activate
        End If
    ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    ' Now select!
    Application.ScreenUpdating = False
    Call SuperAutomation.SuperAutomation
    Application.ScreenUpdating = False
    
    
    ' Amend Rail Price
    If Rail = True Then
    Range("J12").Activate
        Do Until Cells(ActiveCell.Row, "J").Value = ""
        ActiveCell.Value = ActiveCell.Value + RSUP
        ActiveCell.Offset(1, 0).Activate
        Loop
    End If
    
    
    ' Place in Advert Data
    Application.ScreenUpdating = False
    Call SACommit
    Application.ScreenUpdating = False
    ' Finish Up
    Application.ScreenUpdating = False
    temp.Activate
    Cells.ClearContents
    ads.Activate
    end_time = Now()
    Cells(ActiveCell.Row, "O").Value = Format(end_time - start_time, "h:mm:ss")
    Success = True
    NoTours:
    On Error Resume Next
    Resume Skip
    On Error GoTo 0
    Skip:
    ads.Activate
    ActiveCell.Offset(1, 0).Activate
    On Error GoTo 0
    
    
    If Success = True Then
    WB.Save
    Range("X1").Value = ""
    End If
    
    
    ' Update Progress Box
    
    
    If ActiveCell.Row < 4 Then
    Else
    LastTime = Cells(ActiveCell.Row, "O").End(xlUp).Value
    End If
    TotTime = Format(Now() - mt.Range("F2").Value, "hh:mm:ss")
    ProgBox.TotalTime.Caption = TotTime
    ProgBox.LastSelect.Caption = Format(LastTime, "hh:mm:ss")
    ProgBox.Repaint
    
    
    Loop ' Main Loop
    
    
    Unload ProgBox
    Application.ScreenUpdating = True
    
    
    MsgBox "Super Automation Done!"
    
    
    End Sub
    Super Automation Module (I know, that's confusing) The Super Automation code is within a control panel userform, and the Super Automation MODULE is where the products get ranked.
    Code:
    Sub SuperAutomation()
    
    Dim Maxtours As Long
    wbyr = 2019
    nwbyr = 2020
    Set ads = Worksheets("AdSelect")
    Set atm = Worksheets("ATM")
    Set am = Worksheets("AM")
    Set AMPD = Worksheets("AMPD")
    Set remcap = Worksheets("CAP")
    Set adstemp = Worksheets("Temp")
    
    
    If adstemp.Range("A6").Value = "Just Go" Then
    JG = True
    Omega = False
    Else
    Omega = True
    JG = False
    End If
    
    
    Maxtours = adstemp.Range("A5").Value
    
    
    adstemp.Activate
    PaperName = Range("A2").Value
    templatesize = Range("A3").Value
    WCD = ads.Range("A1").Value
    lastrowADST = Cells(Rows.Count, "A").End(xlUp).Row
    
    
    'Open Automation Hub
    
    
    Application.ScreenUpdating = False
    
    
    ahopen = False
    
    
    If ahopen <> True Then
    Application.DisplayAlerts = False
    Set ah = Workbooks.Open("H:\Sales\Regional Press Selections\" & wbyr & "\Automation Hub.xlsx", False, False)
    Application.DisplayAlerts = True
    Else
    ah.Activate
    End If
    
    
    Set Sp = Worksheets("Start Page")
    Set tw1 = Worksheets("Tour Weighting 1")
    Set tw2 = Worksheets("Tour Weighting 2")
    Set ar = Worksheets("Ad Recency")
    Set roi = Worksheets("ROI")
    Set cap = Worksheets("Capacity")
    Set lt = Worksheets("Lead Time")
    Set fr = Worksheets("Frequency")
    Set dv = Worksheets("Discount Value")
    Set dl = Worksheets("Discount Lead")
    Set *** = Worksheets("Assorted")
    
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Temp").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Sheets.Add.Name = "Temp"
    Set temp = Worksheets("Temp")
    Application.ScreenUpdating = False
    
    
    'Populate Start Page
    
    
    Sp.Activate
    Cells.EntireColumn.Hidden = False
    Cells.EntireRow.Hidden = False
    On Error Resume Next
    If ActiveSheet.FilterMode Then
    ActiveSheet.ShowAllData
    End If
    On Error GoTo 0
    
    
    Application.ScreenUpdating = False
    Range("3:3", Range("3:3").End(xlDown)).Delete xlUp
    Range("3:3", Range("3:3").End(xlDown)).Delete xlUp
    Range("A3").Activate
    
    
    adstemp.Range("A12:A" & lastrowADST).Copy Sp.Range("E3")
    adstemp.Range("B12:B" & lastrowADST).Copy Sp.Range("F3")
    adstemp.Range("C12:C" & lastrowADST).Copy Sp.Range("H3")
    adstemp.Range("D12:D" & lastrowADST).Copy Sp.Range("K3")
    Lastrow = Cells(Rows.Count, "E").End(xlUp).Row
    
    
    Range("A3:A" & Lastrow).Value = PaperName
    Range("B3:B" & Lastrow).Value = WCD
    Range("C3:C" & Lastrow).Value = templatesize
    Range("C:C").NumberFormat = "m/d/yyyy"
    Range("H:H").NumberFormat = "m/d/yyyy"
    
    
    Range("I3:I" & Lastrow).FormulaR1C1 = "=LEFT(RC5,1)"
    
    
    Range("F3:K" & Lastrow).Copy
    Range("F3").PasteSpecial xlPasteValues
    Range("A3").Select
    
    
    Range("H:H").NumberFormat = "dd/mm/yyyy"
    Range("K:L").NumberFormat = "#,##0.00"
    Application.ScreenUpdating = False
    
    
    ' Remove blank lines
    
    
    Range("A3").Activate
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "H").Value = "" Then
            ActiveCell.EntireRow.Delete
            ActiveCell.Offset(-1, 0).Activate
        End If
        ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set a = Workbooks.Open("H:\Sales\Regional Press Selections\" & wbyr & "\Advert Data " & wbyr & ".csv", False, True)
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
    
    
    Sp.Activate
    
    
    Range("M3:M" & Lastrow).FormulaR1C1 = "=IFERROR(INDEX('[" & ads.Parent.Name & "]AMPD'!C3,MATCH(RC1,'[" & ads.Parent.Name & "]AMPD'!C5,0),FALSE),"""")"
    
    
    Range("M3:M" & Lastrow).Copy
    Range("M3").PasteSpecial xlPasteValues
    
    
    a.Activate
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("Y2:Y" & Lastrow).FormulaR1C1 = "=COUNTIFS('[Automation Hub.xlsx]Start Page'!C5,RC1)"
    Range("X2:X" & Lastrow).FormulaR1C1 = "=IFERROR(INDEX('[" & ads.Parent.Name & "]AMPD'!C3,MATCH(RC14,'[" & ads.Parent.Name & "]AMPD'!C5,0),FALSE),"""")"
    Range("L:L").NumberFormat = "dd/mm/yyyy"
    Range("X2:Y" & Lastrow).Copy
    Range("X2").PasteSpecial xlPasteValues
    
    
    Sp.Activate
    Lastrow = Cells(Rows.Count, "E").End(xlUp).Row
    
    
    Range("O3:O" & Lastrow).FormulaR1C1 = "=COUNTIFS('" & a.Name & "'!C1,RC5,'" & a.Name & "'!C14,RC1)"
    Range("P3:P" & Lastrow).FormulaR1C1 = "=COUNTIFS('" & a.Name & "'!C24,RC13,'" & a.Name & "'!C1,RC5,'" & a.Name & "'!C12,RC2)"
    Range("R3:R" & Lastrow).FormulaR1C1 = "=COUNTIFS('" & a.Name & "'!C1,RC5,'" & a.Name & "'!C12,RC2)"
    Range("O3:R" & Lastrow).Copy
    Range("O3").PasteSpecial xlPasteValues
    
    
    ThisYear:
    
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wr = Workbooks.Open("H:\Sales\Reporting\New Weekly Report\Templates\" & wbyr & " Weekly Report Master.xlsm", False, True)
    Application.DisplayAlerts = True
    On Error GoTo 0
    Sp.Activate
    Range("G3:G" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(VLOOKUP(RC5,'[" & wbyr & " Weekly Report Master.xlsm]TM Data'!C1:C8,8,FALSE),'[" & wbyr & " Weekly Report Master.xlsm]Categories & Products'!C6:C9,4,FALSE),"""")"
    Application.ScreenUpdating = False
    
    
    AllGood:
    
    
    Range("G3:G" & Lastrow).Copy
    Range("G3").PasteSpecial xlPasteValues
    
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    wr.Close False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
    
    
    'Sister paper = future dev
    
    
    Range("A3").Activate
    
    
    Range("Q3:Q" & Lastrow).Value = 0
    Range("AJ3:AJ" & Lastrow).Value = 0
    
    
    Sp.Activate
    Range("J3:J" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-5],'[" & ads.Parent.Name & "]CAP'!C1:C5,5,0),0)"
    Range("J3:J" & Lastrow).Copy
    Range("J3").PasteSpecial xlPasteValues
    
    
    
    
    Range("A3").Activate
    
    
    ' Remaining Capacity Points
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = ""
    rcap = Cells(ActiveCell.Row, "J").Value
    cap.Activate
    pnt = 0
    Range("A3").Activate
        Do Until Cells(ActiveCell.Row, "A").Value = ""
            If Cells(ActiveCell.Row, "A").Value <= CInt(rcap) And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= CInt(rcap) Then
            pnt = Cells(ActiveCell.Row, "B").Value
            Exit Do
            End If
        ActiveCell.Offset(1, 0).Activate
        Loop
    Sp.Activate
    Cells(ActiveCell.Row, "AF").Value = pnt
    ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    'Template restrictions - temporary logic
    
    
    Sp.Activate
    Range("A3").Activate
    
    
        If InStr(Cells(ActiveCell.Row, "C").Value, "EU") > 0 Then
        Range("D3:D" & Lastrow).Value = "3,5,6,9,Z"
        Else
        Range("D3:D" & Lastrow).Value = "1,2,4,7,8,E,F,L"
        End If
    
    
    'Add other points which can be determined at this stage
    
    
    'Manual Weighting
    Range("Y3:Y" & Lastrow).FormulaR1C1 = "=SUMIFS('Tour Weighting 1'!C3,'Tour Weighting 1'!C1,RC5)+SUMIFS('Tour Weighting 2'!C2,'Tour Weighting 2'!C1,RC6)"
    'PAper Frequency
    Range("AG3:AG" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(IF(RC15>10,10,RC15),Frequency!C1:C2,2,FALSE),0)"
    ' Week Frequency
    Range("AI3:AI" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(IF(RC18>10,10,RC18),Frequency!C1:C2,2,FALSE),0)"
    Range("Y3:AI" & Lastrow).Copy
    Range("Y3").PasteSpecial xlPasteValues
    
    
    ***.Activate
    nyt = Range("B5").Value
    nyf = Range("C5").Value
    tbt = Range("B7").Value
    tbf = Range("C7").Value
    det = Range("B10").Value
    def = Range("C10").Value
    Sp.Activate
    Range("AH3").Activate
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Year(Cells(ActiveCell.Row, "H").Value) = wbyr Then
        Cells(ActiveCell.Row, "AK").Value = nyf
        Else
        Cells(ActiveCell.Row, "AK").Value = nyt
        End If
        If Cells(ActiveCell.Row, "D").Value <> "N/A" And Not InStr(Cells(ActiveCell.Row, "D").Value, CStr(Cells(ActiveCell.Row, "I").Value)) > 0 Then
        Cells(ActiveCell.Row, "AD").Value = tbt
        Else
        Cells(ActiveCell.Row, "AD").Value = tbf
        End If
        If Cells(ActiveCell.Row, "P").Value > 0 Then
        Cells(ActiveCell.Row, "AH").Value = det
        Else
        Cells(ActiveCell.Row, "AH").Value = def
        End If
    ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    'Last used
    
    
    temp.Activate
    Range("A1").Value = "Tourno"
    Range("B1").Value = "Last Used"
    Range("A2").Activate
    a.Activate
    Range("A2").Activate
    run2 = False
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "Y").Value > 0 Then
        ctno = Cells(ActiveCell.Row, "A").Value
        luse = 0
            Do Until Cells(ActiveCell.Row, "A").Value <> ctno
                If Cells(ActiveCell.Row, "N").Value = PaperName And Cells(ActiveCell.Row, "L").Value > luse Then
                luse = Cells(ActiveCell.Row, "L").Value
                End If
            ActiveCell.Offset(1, 0).Activate
            Loop
        temp.Activate
        Cells(ActiveCell.Row, "A").Value = ctno
            If luse = 0 Then
            Cells(ActiveCell.Row, "B").Value = "N/A"
            Else
            Cells(ActiveCell.Row, "B").Value = luse
            End If
        ActiveCell.Offset(1, 0).Activate
        a.Activate
        End If
    ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    temp.Activate
    Range("A2").Activate
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "B").Value = "N/A" Then
        ActiveCell.EntireRow.Delete xlUp
        Else
        ActiveCell.Offset(1, 0).Activate
        End If
    Loop
    
    
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    If Lastrow > 2 Then
    temp.Sort.SortFields.Clear
    temp.Sort.SortFields.Add Key:=Range("B2:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With temp.Sort
        .SetRange Range("A2:B" & Lastrow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    End If
    
    
    Sp.Activate
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Range("N3:N" & Lastrow).FormulaR1C1 = "=IFERROR(VLOOKUP(RC5,Temp!C1:C2,2,FALSE),""N/A"")"
    Range("N3:N" & Lastrow).Copy
    Range("N3").PasteSpecial xlPasteValues
    Range("A3").Activate
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = ""
        If Cells(ActiveCell.Row, "N").Value = "N/A" Then
        wks = 999
        Else
        wks = Round((Cells(ActiveCell.Row, "B").Value - Cells(ActiveCell.Row, "N").Value) / 7, 0)
        End If
    ar.Activate
    Range("A3").Activate
        Do Until Cells(ActiveCell.Row, "A").Value = ""
            If Cells(ActiveCell.Row, "A").Value = wks Or Cells(ActiveCell.Offset(1, 0).Row, "A").Value = "" Then
            pnt = Cells(ActiveCell.Row, "B").Value
            Exit Do
            End If
        ActiveCell.Offset(1, 0).Activate
        Loop
    Sp.Activate
    Cells(ActiveCell.Row, "AB").Value = pnt
    ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    Sp.Activate
    Range("N:N").NumberFormat = "dd/mm/yyyy"
    
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    a.Close False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
    
    
    temp.Activate
    Cells.ClearContents
    
    
    'sp.Activate
    Range("A3").Activate
    'Add discounted price when blank
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = ""
    lt = Round((Cells(ActiveCell.Row, "H").Value - Cells(ActiveCell.Row, "B").Value) / 7, 0)
        If Cells(ActiveCell.Row, "L").Value = "" Then
        fp = Cells(ActiveCell.Row, "K").Value
        dval = 0
            Select Case Cells(ActiveCell.Row, "I").Value
            Case "5", "7", "8", "9"
            Case Else
            dl.Activate
            Range("A3").Activate
                Do Until (Cells(ActiveCell.Row, "A").Value <= lt And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= lt) Or Cells(ActiveCell.Row, "A").Value = ""
                ActiveCell.Offset(1, 0).Activate
                Loop
                If Cells(ActiveCell.Row, "A").Value = "" Then
                    If lt > Cells(ActiveCell.Offset(-1, 0).Row, "A").Value Then
                        If Cells(ActiveCell.Offset(-1, 0).Row, "B").Value = "Y" Then
                        discapp = True
                        Else
                        discapp = False
                        End If
                    Else
                    discapp = False
                    End If
                Else
                    If Cells(ActiveCell.Row, "B").Value = "Y" Then
                    discapp = True
                    Else
                    discapp = False
                    End If
                End If
                If discapp = True Then
                dv.Activate
                Range("A3").Activate
                    Do Until Cells(ActiveCell.Row, "A").Value = ""
                        If Cells(ActiveCell.Row, "A").Value <= fp And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= fp Then
                        dval = Cells(ActiveCell.Row, "B").Value
                        Exit Do
                        End If
                    ActiveCell.Offset(1, 0).Activate
                    Loop
                Else
                dval = 0
                End If
            Sp.Activate
            End Select
        Cells(ActiveCell.Row, "L").Value = Cells(ActiveCell.Row, "K").Value - dval
        End If
    ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    Sp.Activate
    Range("A3").Activate
    
    
    'Open Regional Press Report - to change to wbyr in Feb
    
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set rpr = Workbooks.Open("H:\Sales\Reporting\Regional Press Reporting\Regional Press Reporting " & wbyr & ".xlsm", False, True)
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
    
    
    Set ps = Worksheets("Price Summary")
    Set lts = Worksheets("Lead Time Summary")
    Set tns = Worksheets("Tour Name Summary")
    Set ds = Worksheets("Destination Summary")
    
    
    ***.Activate
    nubt = Range("B9").Value
    nubf = Range("C9").Value
    
    
    Sp.Activate
    Range("A3").Activate
    
    
    Do Until Cells(ActiveCell.Row, "A").Value = ""
    pname = Cells(ActiveCell.Row, "F").Value
    sname = Cells(ActiveCell.Row, "G").Value
    dp = Cells(ActiveCell.Row, "L").Value
    lt = Round((Cells(ActiveCell.Row, "H").Value - Cells(ActiveCell.Row, "B").Value) / 7, 0)
    roi1 = 0
    roi2 = 0
    'roi3 = 0
    use1 = 0
    tns.Activate
    Range("A5").Activate
        Do Until Cells(ActiveCell.Row, "A").Value = ""
            If Cells(ActiveCell.Row, "A").Value = pname Then
                Select Case rop
                Case True
                    Select Case JG
                    Case True
                        If Cells(ActiveCell.Row, "I").Value = "" Then
                        roi1 = 0
                        Else
                        roi1 = Cells(ActiveCell.Row, "I").Value
                        End If
                    use1 = Cells(ActiveCell.Row, "B").Value
                    Case Else
                        If Cells(ActiveCell.Row, "Y").Value = "" Then
                        roi1 = 0
                        Else
                        roi1 = Cells(ActiveCell.Row, "YI").Value
                        End If
                    use1 = Cells(ActiveCell.Row, "R").Value
                    End Select
                Case Else
                    Select Case JG
                    Case True
                        If Cells(ActiveCell.Row, "Q").Value = "" Then
                        roi1 = 0
                        Else
                        roi1 = Cells(ActiveCell.Row, "Q").Value
                        End If
                    use1 = Cells(ActiveCell.Row, "J").Value
                    Case Else
                        If Cells(ActiveCell.Row, "AG").Value = "" Then
                        roi1 = 0
                        Else
                        roi1 = Cells(ActiveCell.Row, "AG").Value
                        End If
                    use1 = Cells(ActiveCell.Row, "Z").Value
                    End Select
                End Select
            Exit Do
            End If
        ActiveCell.Offset(1, 0).Activate
        Loop
        If roi1 = 0 And use1 = 0 Then
        ds.Activate
        Range("A4").Activate
            Do Until Cells(ActiveCell.Row, "A").Value = ""
                If Cells(ActiveCell.Row, "A").Value = sname Then
                    Select Case rop
                    Case True
                        Select Case JG
                        Case True
                            If Cells(ActiveCell.Row, "I").Value = "" Then
                            roi1 = 0
                            Else
                            roi1 = Cells(ActiveCell.Row, "I").Value
                            End If
                        use1 = Cells(ActiveCell.Row, "B").Value
                        Case Else
                            If Cells(ActiveCell.Row, "Y").Value = "" Then
                            roi1 = 0
                            Else
                            roi1 = Cells(ActiveCell.Row, "YI").Value
                            End If
                        use1 = Cells(ActiveCell.Row, "R").Value
                        End Select
                    Case Else
                        Select Case JG
                        Case True
                            If Cells(ActiveCell.Row, "Q").Value = "" Then
                            roi1 = 0
                            Else
                            roi1 = Cells(ActiveCell.Row, "Q").Value
                            End If
                        use1 = Cells(ActiveCell.Row, "J").Value
                        Case Else
                            If Cells(ActiveCell.Row, "AG").Value = "" Then
                            roi1 = 0
                            Else
                            roi1 = Cells(ActiveCell.Row, "AG").Value
                            End If
                        use1 = Cells(ActiveCell.Row, "Z").Value
                        End Select
                    End Select
                End If
            ActiveCell.Offset(1, 0).Activate
            Loop
        End If
    'Below: making the assumption the price brackets in the RPR will not change!
    ps.Activate
    Range("A5").Activate
        If dp < 100 Then
        Range("A5").Activate
        GoTo FoundROI
        End If
        If dp > 999 Then
        Range("A25").Activate
        GoTo FoundROI
        End If
    On Error GoTo NextRow
        For x = 5 To 24
            If CInt(Mid(Cells(ActiveCell.Row, "A").Value, 2, 3)) <= dp And CInt(Mid(Cells(ActiveCell.Offset(1, 0).Row, "A").Value, 2, 3)) >= dp Then
    FoundROI:
                Select Case rop
                Case True
                    Select Case JG
                    Case True
                        If Cells(ActiveCell.Row, "I").Value = "" Then
                        roi2 = 0
                        Else
                        roi2 = Cells(ActiveCell.Row, "I").Value
                        End If
                    Case Else
                        If Cells(ActiveCell.Row, "Y").Value = "" Then
                        roi2 = 0
                        Else
                        roi2 = Cells(ActiveCell.Row, "Y").Value
                        End If
                    End Select
                Case Else
                    Select Case JG
                    Case True
                        If Cells(ActiveCell.Row, "Q").Value = "" Then
                        roi2 = 0
                        Else
                        roi2 = Cells(ActiveCell.Row, "Q").Value
                        End If
                    Case Else
                        If Cells(ActiveCell.Row, "AG").Value = "" Then
                        roi2 = 0
                        Else
                        roi2 = Cells(ActiveCell.Row, "AG").Value
                        End If
                    End Select
                End Select
            Exit For
            End If
    NextRow:
        ActiveCell.Offset(1, 0).Activate
        Next x
    On Error GoTo 0
    roi.Activate
    roiw1 = 0
    roiw2 = 0
    ' roiw3 = 0  !@!
        For x = 1 To 2   'was 1 to 3
        Range("A3").Activate
            Do Until Cells(ActiveCell.Row, "A").Value = ""
                Select Case x
                Case 1
                    If Cells(ActiveCell.Row, "A").Value <= roi1 And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= roi1 Then
                    roiw1 = Cells(ActiveCell.Row, "B").Value
                    Exit Do
                    End If
                Case 2
                    If Cells(ActiveCell.Row, "A").Value <= roi2 And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= roi2 Then
                    roiw2 = Cells(ActiveCell.Row, "B").Value
                    Exit Do
                    End If
    '            Case 3
    '                If Cells(ActiveCell.Row, "A").Value <= roi3 And Cells(ActiveCell.Offset(1, 0).Row, "A").Value >= roi3 Then
    '                roiw3 = Cells(ActiveCell.Row, "B").Value
    '                Exit Do
    '                End If
                End Select
            ActiveCell.Offset(1, 0).Activate
            Loop
        Next x
    Sp.Activate
    Cells(ActiveCell.Row, "S").Value = roi1
    Cells(ActiveCell.Row, "T").Value = roi2
    'Cells(ActiveCell.Row, "U").Value = roi3
    Cells(ActiveCell.Row, "X").Value = roiw1
    Cells(ActiveCell.Row, "AC").Value = roiw2
    'Cells(ActiveCell.Row, "AE").Value = roiw3  !@!
    
    
    ' New Lead Time Calculation
    
    
    If Cells(ActiveCell.Row, "I").Value = "3" Or Cells(ActiveCell.Row, "I").Value = "6" Then
        Cells(ActiveCell.Row, "U").FormulaR1C1 = "=ROUNDUP((RC[-13]-RC[-19])/7,0)"
        Cells(ActiveCell.Row, "U").Value = Cells(ActiveCell.Row, "U").Value
        Cells(ActiveCell.Row, "AE").FormulaR1C1 = "=VLOOKUP(ROUNDUP((RC[-23]-RC[-29])/7,0),'Lead Time'!C[-27]:C[-26],2,0)"
        Cells(ActiveCell.Row, "AE").Value = Cells(ActiveCell.Row, "AE").Value
        Else
        Cells(ActiveCell.Row, "U").FormulaR1C1 = "=ROUNDUP((RC[-13]-RC[-19])/7,0)"
        Cells(ActiveCell.Row, "U").Value = Cells(ActiveCell.Row, "U").Value
        Cells(ActiveCell.Row, "AE").FormulaR1C1 = "=VLOOKUP(ROUNDUP((RC[-23]-RC[-29])/7,0),'Lead Time'!C[-30]:C[-29],2,0)"
        Cells(ActiveCell.Row, "AE").Value = Cells(ActiveCell.Row, "AE").Value
    End If
       
       If use1 = 0 And Cells(ActiveCell.Row, "R").Value < 5 Then
        Cells(ActiveCell.Row, "AM").Value = nubt
        Else
        Cells(ActiveCell.Row, "AM").Value = nubf
        End If
    ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    rpr.Close False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
    
    
    'First summary and ranking
    
    
    Sp.Activate
    Range("V3:V" & Lastrow).FormulaR1C1 = "=SUM(RC24:RC39)"
    Range("W3:W" & Lastrow).FormulaR1C1 = "=RANK(RC22,C22)"
    Range("V3:W" & Lastrow).Copy
    Range("V3").PasteSpecial xlPasteValues
    
    
    'Diversity check, and second (and third etc.) ranking
    
    
    ***.Activate
    div1t = Range("B3").Value
    div1f = Range("C3").Value
    div2t = Range("B4").Value
    div2f = Range("C4").Value
    pt = Range("B8").Value
    pf = Range("C8").Value
    
    
    'Sort by ranking
    
    
    Sp.Activate
        Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
        Sp.Sort.SortFields.Clear
        Sp.Sort.SortFields.Add Key:=Range("W3:W" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With Sp.Sort
            .SetRange Range("A3:AM" & Lastrow)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    crow = 0
    
    
    ' Diversity Checks and re-ranking
    
    
    For x = 1 To Maxtours
    Range("A3").Activate
        Do Until (Cells(ActiveCell.Row, "W").Value >= x And ActiveCell.Row > crow) Or Cells(ActiveCell.Row, "W").Value = x Or Cells(ActiveCell.Row, "A").Value = ""
        ActiveCell.Offset(1, 0).Activate
        Loop
        If Cells(ActiveCell.Row, "A").Value <> "" Then
        crow = ActiveCell.Row
        tname = Cells(ActiveCell.Row, "F").Value
        sname = Cells(ActiveCell.Row, "G").Value
        tdig = Cells(ActiveCell.Row, "I").Value
        dcod = Mid(Cells(ActiveCell.Row, "E").Value, 2, 2)
        dp = Cells(ActiveCell.Row, "K").Value
        Cells(ActiveCell.Row, "Z").Value = 100
        Cells(ActiveCell.Row, "AA").Value = 100
        Cells(ActiveCell.Row, "AL").Value = pt
        ActiveCell.Offset(1, 0).Activate
    'Range("A3").Activate
            Do Until Cells(ActiveCell.Row, "A").Value = ""
                If Cells(ActiveCell.Row, "Z").Value = 0 And Cells(ActiveCell.Row, "AA").Value = 0 Then
                    If (ActiveCell.Row <> crow Or (ActiveCell.Row < crow And Cells(ActiveCell.Row, "W").Value >= x)) Then
                        If Cells(ActiveCell.Row, "F").Value = tname Or Cells(ActiveCell.Row, "G").Value = sname Then
                        Cells(ActiveCell.Row, "Z").Value = div1t
                        Else
                        Cells(ActiveCell.Row, "Z").Value = div1f
                        End If
                        If Mid(Cells(ActiveCell.Row, "E").Value, 2, 2) = dcod And Left(Cells(ActiveCell.Row, "E").Value, 1) <> "E" Then
                        Cells(ActiveCell.Row, "AA").Value = div2t
                        Else
                        Cells(ActiveCell.Row, "AA").Value = div2f
                        End If
                        If Cells(ActiveCell.Row, "K").Value >= (dp * 0.66) And Cells(ActiveCell.Row, "K").Value <= (dp * 1.33) Then
                        Cells(ActiveCell.Row, "AL").Value = pt
                        Else
                        Cells(ActiveCell.Row, "AL").Value = pf
                        End If
                    Else
                    Cells(ActiveCell.Row, "Z").Value = div1f
                    Cells(ActiveCell.Row, "AA").Value = div2f
                    Cells(ActiveCell.Row, "AL").Value = pt
                    End If
                End If
            ActiveCell.Offset(1, 0).Activate
            Loop
        Range("V3:V" & Lastrow).FormulaR1C1 = "=SUM(RC24:RC39)"
        Range("W3:W" & Lastrow).FormulaR1C1 = "=RANK(RC22,C22)"
        Range("V3:W" & Lastrow).Copy
        Range("V3").PasteSpecial xlPasteValues
        Sp.Sort.SortFields.Clear
        Sp.Sort.SortFields.Add Key:=Range("W3:W" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With Sp.Sort
            .SetRange Range("A3:AM" & Lastrow)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        End If
    Next x
    
    
    Range("A3").Activate
    
    
    On Error GoTo NoSave
    
    
    Sp.Copy
    Range("1:1").Delete xlUp
    
    
    
    
    If rop = True Then
    newdir = "H:\Sales\Regional Press Selections\" & wbyr & "\Automation Files\ROP\wc " & Format(DateValue(WCD), "yyyy-mm-dd")
    Else
    newdir = "H:\Sales\Regional Press Selections\" & wbyr & "\Automation Files\RT\wc " & Format(DateValue(WCD), "yyyy-mm-dd")
    End If
    
    
    If Dir(newdir, vbDirectory) = vbNullString Then
    On Error Resume Next
    MkDir newdir
    On Error GoTo 0
    End If
    
    
    'nsname = Replace(PaperName, "/", "") & " - " & PaperName !@!
    
    
    nsname = Replace(PaperName, "/", "&")
    
    
    tsize = adstemp.Range("A4").Value
    
    
    Set n = ActiveWorkbook
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    'n.SaveAs filename:=newdir & "\" & nsname & " - Super - " & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    If adstemp.Range("A6").Value = "Just Go" Then
    n.SaveAs filename:=newdir & "\" & nsname & " - Super - " & tsize & " JG" & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    Else
    n.SaveAs filename:=newdir & "\" & nsname & " - Super - " & tsize & " OM" & ".csv", FileFormat:=xlCSV, CreateBackup:=False
    End If
    n.Close True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = False
    
    
    
    
    NoSave:
    Resume Skip
    Skip:
    ' Bring results back to adstemp
    Range("E3:E" & Lastrow).Copy adstemp.Range("H12")
    Range("F3:F" & Lastrow).Copy adstemp.Range("I12")
    Range("K3:K" & Lastrow).Copy adstemp.Range("J12")
    Range("W3:W" & Lastrow).Copy adstemp.Range("K12")
    Range("V3:V" & Lastrow).Copy adstemp.Range("L12")
    Range("Y3:Y" & Lastrow).Copy adstemp.Range("M12")
    
    
    Application.EnableEvents = True
    Application.DisplayAlerts = False
    
    
    If ah.ReadOnly = False Then
    ah.Close True
    Else
    ah.Close False
    End If
    
    
    
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    
    End Sub
    Last edited by RockandGrohl; Sep 3rd, 2019 at 11:30 AM.

  2. #2
    MrExcel MVP
    Moderator
    xenou's Avatar
    Join Date
    Mar 2007
    Location
    Clev. OH, USA
    Posts
    16,471
    Post Thanks / Like
    Mentioned
    11 Post(s)
    Tagged
    1 Thread(s)

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

    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:
    Code:
    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:
    Code:
    Worksheets("Temp").Cells.Clear
    If you want to put that worksheet into another workbook then "copy" it rather than "move" it.

    Using: Office 2010/Win7 (work) Office 2010/Win7 (home)

    You are rich in proportion to the number of things you can let alone.
    -- Henry David Thoreau

  3. #3
    Board Regular
    Join Date
    Aug 2018
    Posts
    321
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.
    Last edited by RoryA; Sep 24th, 2019 at 06:13 AM.

  4. #4
    Board Regular
    Join Date
    Aug 2018
    Posts
    321
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.

    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.
    Last edited by RockandGrohl; Sep 24th, 2019 at 08:07 AM.

  5. #5
    MrExcel MVP
    Moderator
    xenou's Avatar
    Join Date
    Mar 2007
    Location
    Clev. OH, USA
    Posts
    16,471
    Post Thanks / Like
    Mentioned
    11 Post(s)
    Tagged
    1 Thread(s)

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

    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
    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.

    Using: Office 2010/Win7 (work) Office 2010/Win7 (home)

    You are rich in proportion to the number of things you can let alone.
    -- Henry David Thoreau

  6. #6
    Board Regular
    Join Date
    Aug 2018
    Posts
    321
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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?

  7. #7
    MrExcel MVP
    Moderator
    xenou's Avatar
    Join Date
    Mar 2007
    Location
    Clev. OH, USA
    Posts
    16,471
    Post Thanks / Like
    Mentioned
    11 Post(s)
    Tagged
    1 Thread(s)

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

    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).
    Last edited by xenou; Sep 24th, 2019 at 10:17 AM.

    Using: Office 2010/Win7 (work) Office 2010/Win7 (home)

    You are rich in proportion to the number of things you can let alone.
    -- Henry David Thoreau

  8. #8
    Board Regular
    Join Date
    Aug 2018
    Posts
    321
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.

  9. #9
    MrExcel MVP
    Moderator
    xenou's Avatar
    Join Date
    Mar 2007
    Location
    Clev. OH, USA
    Posts
    16,471
    Post Thanks / Like
    Mentioned
    11 Post(s)
    Tagged
    1 Thread(s)

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

    Okay sounds good so far.

    Using: Office 2010/Win7 (work) Office 2010/Win7 (home)

    You are rich in proportion to the number of things you can let alone.
    -- Henry David Thoreau

  10. #10
    Board Regular
    Join Date
    Aug 2018
    Posts
    321
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    Quote Originally Posted by xenou View Post
    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.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •