VBA - This is causing my code to loop and I can't stop it

R

RockandGrohl

Well-known Member
Joined
Aug 1, 2018
Messages
810
Office Version
  1. 365
Platform
  1. Windows
Code: 
NoTours:Resume Skip
Skip:
ads.Activate
ActiveCell.Offset(1, 0).Activate
WB.Save

For some reason after I hit WB.Save, it goes back to "NoTours" and just goes over and over.

Do I need to insert something after the WB.Save to stop it returning to NoTours?

Thanks.
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
Depends on what the rest of the code is & how it's being called.
 
Upvote 0
You asked for it :rofl:

Code: 
SuperAuto_Click()

Dim Lastrow, LastrowAD As Long, WB As Workbook


Set ads = Worksheets("Adselect")
Set atm = Worksheets("ATM")
Set am = Worksheets("AM")
Set AMPD = Worksheets("AMPD")
'Set temp = Worksheets("Temp")
Set cap = Worksheets("CAP")
Set tod = Worksheets("TOD")
Set mt = Worksheets("MacroTimings")
wbyr = 2019
nwbyr = 2020


Application.ScreenUpdating = False
ControlPanel.Hide


'ListEnd = temp.Range("B11").Value


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)
tdate = WCDV + 28
'Range("A3").Activate


Omega = False
JG = False


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


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
    Do Until Cells(ActiveCell.Row, "A").Value <> "JP Filler Ads"
    ActiveCell.Offset(1, 0).Activate
    Loop
End If


Do Until Cells(ActiveCell.Row, "F").Value = "Just Go" Or Cells(ActiveCell.Row, "A").Value = ""
ActiveCell.Offset(1, 0).Activate
    If Overwrite = False And Cells(ActiveCell.Row, "E").Value = "Y" Then
    GoTo Skip
    End If
Loop


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


ProgBox.ProgTitleNameFront.Caption = PapNam
ProgBox.ProgTitleNameBack.Caption = PapNam


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






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 = cost
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
temp.Columns("A:A").EntireColumn.AutoFit


    tempdonk = 0
    temp.Activate
    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


' Determine what Travel type to go with for the tour


Range("B5").Activate
PUdonk = 0


If Rail = True Then
    Do Until Cells(5, ActiveCell.Column).Value = ""
        If ActiveCell.Offset(2, 0).Value = "Rail" 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 Air = True Then
   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
   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 SD = False And Rail = False And Air = False Then
Coach = True
Range("A7").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("\\chw-dc03\company\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


Dim TourCopyRng As Range
Dim DateCopyRng As Range
Dim NameCopyRng As Range
Dim CostCopyRng As Range




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:W" & LastrowAD).FormulaR1C1 = "=SUM(COUNTIF(RC[-14],{""*" & PU1 & "*"",""*" & PU2 & "*"",""*" & PU3 & "*"",""*" & PU4 & "*"",""*" & PU5 & "*""}))"


    ActiveSheet.Range("$A$1:$W$" & LastrowAD).AutoFilter Field:=5, Criteria1:=">=" & CLng(DateValue(tdate))     ' Tour date
    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
    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*"
    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


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




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


' 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")
NoTours:
Resume Skip
Skip:
ads.Activate
ActiveCell.Offset(1, 0).Activate
WB.Save


' 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
 
Upvote 0
WB does not seem to have been set & therefore the error handler kicks in
 
Upvote 0
Ah, I expect that will do it! I don't often set WB's as I don't really use code that auto-saves, but this necessitates it!


While I have you, you know when you copy a worksheet and it creates a temporary file in your AppData, like "Users/Fluff/AppData/Local/Temp/VB340412.tmp"

Because I'm on a network I think Excel is getting confused as to where the temp file should be, can I error-handle my way out of Excel crashing when it can't find the temp file?

As it stands I get a "file not found" even though I go to the network location and it's there.
 
Upvote 0
I cannot help with your new question, as I am not on a network and I have no idea why you are trying to open temp files.
 
Upvote 0
When you do "worksheet.copy" it automatically copies and pastes the worksheet to a temp file held in your AppData, I think you can test this yourself by copying a worksheet then navigating to your file path as mentioned above and you should see a new file beginning in "VB" - if you paste, it should go away.
 
Upvote 0
You must log in or register to reply here.

Similar threads

SlinkRN
  • Solved
Handling Multiple Errors within one loop
Replies
7
Views
289
SlinkRN
SlinkRN
leyeti77
  • Question Question
VBA FollowHyperlink : Excel file do not open until Break or Stop instruction ?
Replies
2
Views
316
leyeti77
leyeti77
S
  • Solved
VBA code to fill in blank cells running really slowly
Replies
6
Views
443
Joe4
Joe4
F
  • Solved
How to make loop stop when the cell is empty? (VBA)
Replies
3
Views
298
kvsrinivasamurthy
K
D
  • Question Question
Modify a worksheet without registering it as a change
Replies
1
Views
125
Kaper
Kaper

Forum statistics

Threads
1,224,812
Messages
6,181,085
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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