Macro stops working before end sub with no prompt

E

_eNVy_

Board Regular
Joined
Feb 9, 2018
Messages
66
Office Version
  1. 365
Platform
  1. Windows
Hi all,

My macro stops working before finishing the code.
Strangely, it has worked for the past 5+ months and when trying to run today, it just stops!
Code below :

VBA Code: 
Sub OneA_Auto()
    
    Dim lRow As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet
    Dim rng1 As Range, ONEa As Range
    
    Set ws1 = Worksheets("1a boxi")
    Set ws2 = Worksheets("1a list of client services")
    Set ws3 = Worksheets("1a unique clients list")
    Set ws4 = Worksheets("Raw Boxi")
    Set ws5 = Worksheets("Macro Centre")
    
    ws4.Activate
    
    lRow = Cells.Find(What:="*", _
           After:=Range("A1"), _
           LookAt:=xlPart, _
           LookIn:=xlFormulas, _
           SearchOrder:=xlByRows, _
           SearchDirection:=xlPrevious, _
           MatchCase:=False).Row
    
    ws4.Range("A2:Q" & lRow).Copy
    
    ws1.Activate
    Range("A2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    
        lRow = Cells.Find(What:="*", _
           After:=Range("A1"), _
           LookAt:=xlPart, _
           LookIn:=xlFormulas, _
           SearchOrder:=xlByRows, _
           SearchDirection:=xlPrevious, _
           MatchCase:=False).Row
    
    Set rng1 = Range("R3:T" & lRow)
    
    ws1.Range("R3").Formula = "=TEXTJOIN("","",TRUE,A3,K3,L3)"
    ws1.Range("S3").Formula = "=XLOOKUP(K3,'PSR lookup'!A:A,'PSR lookup'!B:B,"""")"
    ws1.Range("T3").Formula = "=COUNTIF(R$3:R3,R3)"
        
    ws1.Range("R3:T3").AutoFill _
                                Destination:=rng1, Type:=xlFillDefault
    rng1.Value = rng1.Value
    
    '--Delete all duplicates (all non-1's)
    
            lRow = Cells.Find(What:="*", _
           After:=Range("A1"), _
           LookAt:=xlPart, _
           LookIn:=xlFormulas, _
           SearchOrder:=xlByRows, _
           SearchDirection:=xlPrevious, _
           MatchCase:=False).Row
          
    With ActiveSheet
        .AutoFilterMode = False
        With Range("A2:T" & lRow)
            .AutoFilter Field:=20, Criteria1:="<>1"
            On Error Resume Next
            .Offset(1).SpecialCells(12).EntireRow.Delete
        End With
        .AutoFilterMode = False
    End With
    
            lRow = Cells.Find(What:="*", _
           After:=Range("A1"), _
           LookAt:=xlPart, _
           LookIn:=xlFormulas, _
           SearchOrder:=xlByRows, _
           SearchDirection:=xlPrevious, _
           MatchCase:=False).Row
          
    ws1.Range("A2:Q" & lRow).Copy
    
'-- Moving to Sheet 1a client services
    
    ws2.Activate
    Range("A1").PasteSpecial Paste:=xlPasteValues
    
 '-- Finding the last cell in Column A in Sheet 1b client services
          
            lRow = Cells.Find(What:="*", _
           After:=Range("A1"), _
           LookAt:=xlPart, _
           LookIn:=xlFormulas, _
           SearchOrder:=xlByRows, _
           SearchDirection:=xlPrevious, _
           MatchCase:=False).Row
          
    With Range("A2:A" & lRow)
        .NumberFormat = "General"
        .Value = .Value
            
    End With

    '--Copy client list from 1a client services and remove duplicates to paste into 1a unique clients list

    ws2.Range("A1:A" & lRow).Cells(1, 1).Copy ws3.Cells(3, 1)
    ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2").Value, Unique:=True
    
    '==============STOPS WORKING HERE!!!!========================

    '-- Create formulas
    
    ws3.Activate

    '--Client lines
    ws3.Range("B3").Formula = "=COUNTIF('1a list of client services'!A:A,A3)"
    '--Count of non-DP Services
    ws3.Range("C3").Formula = "=COUNTIFS('1a list of client services'!A:A,$A3,'1a list of client services'!O:O,0)"
    '--Age Band
    ws3.Range("D3").Formula = "=XLOOKUP(A3,'1a list of client services'!A:A,'1a list of client services'!F:F,"""",0)"
    '--PSR
    ws3.Range("E3").Formula = "=XLOOKUP(XLOOKUP(A3,'1a list of client services'!A:A,'1a list of client services'!K:K,"""",0),'PSR lookup'!A:A,'PSR lookup'!B:B,"""",0)"
    '--SATL: Support Setting/Delivery Mechanism
    ws3.Range("F3").Formula = "=IF(H3=1,""1. Nursing"",IF(I3=1,""2. Residential"",IF(AND(J3=1,C3=0),""3. Direct Payments"",IF(AND(J3=1,C3>0),""4. Part Direct Payments"",""5. CASSR Managed Personal Budget""))))"
    '--Unique ID
    ws3.Range("G3").Formula = "=TEXTJOIN("","",FALSE,A3,F3)"
    '--Nursing Indicator
    ws3.Range("H3").Formula = "=COUNTIFS('1a list of client services'!$M:$M,"">0"",'1a list of client services'!$A:$A,$A3)"
    '--Residential Indicator
    ws3.Range("I3").Formula = "=COUNTIFS('1a list of client services'!$N:$N,"">0"",'1a list of client services'!$A:$A,$A3)"
    '--Direct Payment Indicator
    ws3.Range("J3").Formula = "=COUNTIFS('1a list of client services'!$O:$O,"">0"",'1a list of client services'!$A:$A,$A3)"
    '--Hierachy Test
    ws3.Range("K3").Formula = "=COUNTIFS('1a list of client services'!$P:$P,"">0"",'1a list of client services'!$A:$A,$A3)"
    '--Other Indicator
    ws3.Range("L3").Formula = "=COUNTIFS('1a list of client services'!$Q:$Q,"">0"",'1a list of client services'!$A:$A,$A3)"
    
    '-- Defining 1a unique clients list formula range
    
    lRow2 = Cells.Find(What:="*", _
           After:=Range("A1"), _
           LookAt:=xlPart, _
           LookIn:=xlFormulas, _
           SearchOrder:=xlByRows, _
           SearchDirection:=xlPrevious, _
           MatchCase:=False).Row
    
    Set ONEa = Range("B3:L" & lRow2)
    
    '-- Autofill Formulas and turn them into hard values
    
    ws3.Range("B3:L3").AutoFill _
                                Destination:=ONEa, Type:=xlFillDefault
    ONEa.Value = ONEa.Value
    
    ws5.Activate
    
End Sub

In the code I have indicated where it stops.
I have gone through the code line by line (F8) and it just stops working, no prompt, no message, like it was meant to stop!
Any explanation and workaround is greatly appreciated.
 
Sort by date Sort by votes
Do you have any other event code in the workbook (eg a worksheet_change code on the "1a unique clients list" sheet)?

Do you use any conditional formatting that uses UDFs?
 
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Anthony47 said:
Stop (for me) means that it halts waiting for something external (like when it enter the debug mode); Terminate is like when you reach End Sub or Exit Sub; get "Stuck" means that it looks like excel is frozen (maybe for minutes waiting for a complex Unique list to be prepared; by the way, wchich is the value for

Which is the value for lRow before the failure?

Did you reboot your pc and the error still occours?

If you add the following OnError, does it go to GErr and then stops on the "Stop"?
VBA Code: 
'..
On Error GoTo GErr               'ADDED
ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2"), Unique:=True
'..
'..
    ws5.Activate    'Yours
'>>> ADDED:
Exit Sub
GErr:
    Debug.Print Err.Number, Err.Description
    Stop
End Sub                  'Yours

By the way, does ws3.Range("A2") contains the list?
Click to expand...
By adding your OnError code, it just acts like it does without it.
It does not Stop in the sense it is waiting for something.
It Terminates before reaching End Sub.
Does not get Stuck either.

ws3.Range("A2") contains a list of unique values from the lRow before Failure. The new unique list is then whittled down to 5,396.
VBA Code: 
ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2"), Unique:=True

After a long weekend break, turning laptop on (after restarting it as well) has not resolved the issue.
 
Upvote 0
RoryA said:
Do you have any other event code in the workbook (eg a worksheet_change code on the "1a unique clients list" sheet)?

Do you use any conditional formatting that uses UDFs?
Click to expand...
Each code has its own module and none of which are being called upon.

No conditional formatting is used in the entire workbook/any codes either.
 
Upvote 0
I have no further ideas to develop here; maybe having a test workbook.... (maybe)
 
Upvote 0
Anthony47 said:
I have no further ideas to develop here; maybe having a test workbook.... (maybe)
Click to expand...
Thanks for your efforts.
I've never encountered this before and it seems so very strange that it would decide to stop functioning when it was working fine before.
 
Upvote 0
I think this line:
VBA Code: 
ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2").Value, Unique:=True
Should be:
VBA Code: 
ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2"), Unique:=True

Found that when stepping through code after using the sound suggestion in post 7
 
Upvote 0
I think the main thing that is killing the code is the fact that the sheet: 'PSR lookup' is referenced in the formulae but is not included in the macro, does this sheet exist in the file?

For me the code dies on the below line:
VBA Code: 
ws3.Range("E3").Formula = "=XLOOKUP(XLOOKUP(A3,'1a list of client services'!A:A,'1a list of client services'!K:K,"""",0),'PSR lookup'!A:A,'PSR lookup'!B:B,"""",0)"
 
Upvote 0
Let's try once more...
I have added a few Debug.Print to the code, to print some debug information; also, the failing instruction has been wrapped in On Error Resume next /On Error Goto 0
Try executing the macro with these modifications; when it "completes" open the vba "Immediate Window" (from the vba, press Contr-g; or Menu /View /Immediate window). Then copy what is listed there from the line >>>>>>>> at xxxxxx.xxx till the end and insert these info in your next message.

The modified code (the first part of your macro):
VBA Code: 
Sub OneA_Auto()
  
Dim lRow As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet
Dim rng1 As Range, ONEa As Range

Set ws1 = Worksheets("1a boxi")
Set ws2 = Worksheets("1a list of client services")
Set ws3 = Worksheets("1a unique clients list")
Set ws4 = Worksheets("Raw Boxi")
Set ws5 = Worksheets("Macro Centre")

Debug.Print ">>>>>>>> at " & Format(Timer, "0.000")
ws4.Activate
Debug.Print "A1", ActiveSheet.Name
lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "A2", lRow
ws4.Range("A2:Q" & lRow).Copy

ws1.Activate
Debug.Print "B1", ActiveSheet.Name
Range("A2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "B2", lRow
Set rng1 = Range("R3:T" & lRow)
Debug.Print "B3", rng1.Address(0, 0), rng1.Parent.Name
ws1.Range("R3").Formula = "=TEXTJOIN("","",TRUE,A3,K3,L3)"
ws1.Range("S3").Formula = "=XLOOKUP(K3,'PSR lookup'!A:A,'PSR lookup'!B:B,"""")"
ws1.Range("T3").Formula = "=COUNTIF(R$3:R3,R3)"
  
ws1.Range("R3:T3").AutoFill _
                            Destination:=rng1, Type:=xlFillDefault
rng1.Value = rng1.Value

'--Delete all duplicates (all non-1's)

        lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "C1", lRow
With ActiveSheet
    .AutoFilterMode = False
    With Range("A2:T" & lRow)
        Debug.Print "C2", ActiveSheet.Name, Application.WorksheetFunction.CountA(Range("A2:T" & lRow))
        .AutoFilter Field:=20, Criteria1:="<>1"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
        On Error GoTo 0                                 'RoryA post
    End With
    .AutoFilterMode = False
    Debug.Print "C3", Application.WorksheetFunction.CountA(Range("A2:T" & lRow))
End With

        lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "D1", ActiveSheet.Name, lRow
ws1.Range("A2:Q" & lRow).Copy

'-- Moving to Sheet 1a client services

ws2.Activate
Debug.Print "E1", ActiveSheet.Name
Range("A1").PasteSpecial Paste:=xlPasteValues

'-- Finding the last cell in Column A in Sheet 1b client services
    
        lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "E2", lRow
With Range("A2:A" & lRow)
    .NumberFormat = "General"
    .Value = .Value
      
End With

'--Copy client list from 1a client services and remove duplicates to paste into 1a unique clients list
Debug.Print "KA", Application.WorksheetFunction.CountA(ws3.Cells(3, 1).Resize(lRow, 1))

ws2.Range("A1:A" & lRow).Cells(1, 1).Copy ws3.Cells(3, 1)
Debug.Print "KB", ActiveSheet.Name, Application.WorksheetFunction.CountA(ws3.Cells(3, 1).Resize(lRow, 1))
Debug.Print "KC", Timer
On Error Resume Next
ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2"), Unique:=True
On Error Resume Next
Debug.Print "K??", Err.Number, Application.WorksheetFunction.CountA(ws3.Cells(3, 1).Resize(lRow, 1))

'==============STOPS WORKING HERE!!!!========================

'-- Create formulas
'etc
'etc
'etc

Another question: how this macro get started? Is it depending on any Workbook /Worksheet event (ex: WorkbookOpen, WorksheetChange, etc etc)? Or on ActiveX /Userform interactions?
 
Upvote 0
Solution
Anthony47 said:
Let's try once more...
I have added a few Debug.Print to the code, to print some debug information; also, the failing instruction has been wrapped in On Error Resume next /On Error Goto 0
Try executing the macro with these modifications; when it "completes" open the vba "Immediate Window" (from the vba, press Contr-g; or Menu /View /Immediate window). Then copy what is listed there from the line >>>>>>>> at xxxxxx.xxx till the end and insert these info in your next message.

The modified code (the first part of your macro):
VBA Code: 
Sub OneA_Auto()
 
Dim lRow As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet
Dim rng1 As Range, ONEa As Range

Set ws1 = Worksheets("1a boxi")
Set ws2 = Worksheets("1a list of client services")
Set ws3 = Worksheets("1a unique clients list")
Set ws4 = Worksheets("Raw Boxi")
Set ws5 = Worksheets("Macro Centre")

Debug.Print ">>>>>>>> at " & Format(Timer, "0.000")
ws4.Activate
Debug.Print "A1", ActiveSheet.Name
lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "A2", lRow
ws4.Range("A2:Q" & lRow).Copy

ws1.Activate
Debug.Print "B1", ActiveSheet.Name
Range("A2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "B2", lRow
Set rng1 = Range("R3:T" & lRow)
Debug.Print "B3", rng1.Address(0, 0), rng1.Parent.Name
ws1.Range("R3").Formula = "=TEXTJOIN("","",TRUE,A3,K3,L3)"
ws1.Range("S3").Formula = "=XLOOKUP(K3,'PSR lookup'!A:A,'PSR lookup'!B:B,"""")"
ws1.Range("T3").Formula = "=COUNTIF(R$3:R3,R3)"
 
ws1.Range("R3:T3").AutoFill _
                            Destination:=rng1, Type:=xlFillDefault
rng1.Value = rng1.Value

'--Delete all duplicates (all non-1's)

        lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "C1", lRow
With ActiveSheet
    .AutoFilterMode = False
    With Range("A2:T" & lRow)
        Debug.Print "C2", ActiveSheet.Name, Application.WorksheetFunction.CountA(Range("A2:T" & lRow))
        .AutoFilter Field:=20, Criteria1:="<>1"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
        On Error GoTo 0                                 'RoryA post
    End With
    .AutoFilterMode = False
    Debug.Print "C3", Application.WorksheetFunction.CountA(Range("A2:T" & lRow))
End With

        lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "D1", ActiveSheet.Name, lRow
ws1.Range("A2:Q" & lRow).Copy

'-- Moving to Sheet 1a client services

ws2.Activate
Debug.Print "E1", ActiveSheet.Name
Range("A1").PasteSpecial Paste:=xlPasteValues

'-- Finding the last cell in Column A in Sheet 1b client services
   
        lRow = Cells.Find(What:="*", _
       After:=Range("A1"), _
       LookAt:=xlPart, _
       LookIn:=xlFormulas, _
       SearchOrder:=xlByRows, _
       SearchDirection:=xlPrevious, _
       MatchCase:=False).Row
Debug.Print "E2", lRow
With Range("A2:A" & lRow)
    .NumberFormat = "General"
    .Value = .Value
     
End With

'--Copy client list from 1a client services and remove duplicates to paste into 1a unique clients list
Debug.Print "KA", Application.WorksheetFunction.CountA(ws3.Cells(3, 1).Resize(lRow, 1))

ws2.Range("A1:A" & lRow).Cells(1, 1).Copy ws3.Cells(3, 1)
Debug.Print "KB", ActiveSheet.Name, Application.WorksheetFunction.CountA(ws3.Cells(3, 1).Resize(lRow, 1))
Debug.Print "KC", Timer
On Error Resume Next
ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2"), Unique:=True
On Error Resume Next
Debug.Print "K??", Err.Number, Application.WorksheetFunction.CountA(ws3.Cells(3, 1).Resize(lRow, 1))

'==============STOPS WORKING HERE!!!!========================

'-- Create formulas
'etc
'etc
'etc

Another question: how this macro get started? Is it depending on any Workbook /Worksheet event (ex: WorkbookOpen, WorksheetChange, etc etc)? Or on ActiveX /Userform interactions?
Click to expand...

I am truly baffled.
I ran the code today and it works........I cannot understand what temperamental emotional state my Excel is going through.

In response to your much appreciated code I get the following from my Immediate Window :

>>>>>>>> at 40314.700
A1 Raw Boxi
A2 9463
B1 1a boxi
B2 9463
B3 R3:T9463 1a boxi
C1 9463
C2 1a boxi 146101
C3 92807
D1 1a boxi 5963
E1 1a list of client services
E2 5962
KA 0
KB 1a list of client services 1
KC 40331.59
K?? 0 5396

Once your code had finished, the macro does what it was intended to do.

To answer your question - the macro gets started by the macro being assigned a button.
 
Upvote 0
Georgiboy said:
I think the main thing that is killing the code is the fact that the sheet: 'PSR lookup' is referenced in the formulae but is not included in the macro, does this sheet exist in the file?

For me the code dies on the below line:
VBA Code: 
ws3.Range("E3").Formula = "=XLOOKUP(XLOOKUP(A3,'1a list of client services'!A:A,'1a list of client services'!K:K,"""",0),'PSR lookup'!A:A,'PSR lookup'!B:B,"""",0)"
Click to expand...
Thank you for your comment, yes PSR lookup is a tab on its own and exists in the file.

In response to your earlier comment, I had amended that also but that had not caused to fix the issue at the time.
If you are not aware of my previous reply to Anthony47 - the macro miraculously works....as of today.
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
AutoFilter Field Macro Returns a Header Row only
2
Replies
11
Views
102
MARK858
MARK858
D
  • Question Question
Random selection modification not working
Replies
2
Views
357
Damian37
D
E
  • Solved
Delete Entire Rows Based on Not Equal to Text
Replies
3
Views
605
_eNVy_
E
E
  • Solved
Macro to delete all rows
Replies
2
Views
555
Alex Blakenburg
A
H
  • Question Question
Adjust an existing formula based on most recently added column and prior month end date.
Replies
1
Views
341
healeydm
H

Forum statistics

Threads
1,223,888
Messages
6,175,203
Members
452,617
Latest member
Narendra Babu D

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