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.
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
Has the name of your WS3 tab changed from "1a unique clients list"? no spaces before or after?
 
Upvote 0
Does the macro stop on that line or does it exit on that line without executing the remaining code?

Should the portion CopyToRange:=ws3.Range("A2").Value be CopyToRange:=ws3.Range("A2") (a Range, not a Value)?
Which vba module contains the macro?
 
Upvote 0
Anthony47 said:
Does the macro stop on that line or does it exit on that line without executing the remaining code?

Should the portion CopyToRange:=ws3.Range("A2").Value be CopyToRange:=ws3.Range("A2") (a Range, not a Value)?
Which vba module contains the macro?
Click to expand...
You are correct. I have removed but it still has not fixed the issue.
It stops after executing the now amended code :
VBA Code: 
    ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2"), Unique:=True

Module3 contains the macro.
In previous Modules, a similar macro executes with slight date alterations - they too have stopped working at the point part of the code.
 
Upvote 0
Does the macro Stops, Terminates without completing the instructions, or get stuck on that line?

Could you share the workbook that fails?
 
Last edited:
Upvote 0
CHange this part:

Code: 
            On Error Resume Next
            .Offset(1).SpecialCells(12).EntireRow.Delete

to this:

Code: 
            On Error Resume Next
            .Offset(1).SpecialCells(12).EntireRow.Delete
           On Error Goto 0

and then subsequent errors won't just be hidden from you.
 
Upvote 0
Anthony47 said:
Does the macro Stops, Terminates without completing the instructions, or get stuck on that line?

Could you share the workbook that fails?
Click to expand...
What is your definition of Stops and terminates?
It executes
VBA Code: 
ws2.Range("A1:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws3.Range("A2"), Unique:=True
It then does not go to the next line of
VBA Code: 
ws3.Activate

Sadly, I wont be able to share the workbook as is - I will need to redact a few things.
 
Upvote 0
RoryA said:
CHange this part:

Code: 
            On Error Resume Next
            .Offset(1).SpecialCells(12).EntireRow.Delete

to this:

Code: 
            On Error Resume Next
            .Offset(1).SpecialCells(12).EntireRow.Delete
           On Error Goto 0

and then subsequent errors won't just be hidden from you.
Click to expand...
Thank you,

I have included the suggested code but still no prompts as to why the code has stopped.
 
Upvote 0
What is your definition of Stops and terminates?
Click to expand...
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?
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
Random selection modification not working
Replies
2
Views
158
Damian37
D
E
  • Solved
Delete Entire Rows Based on Not Equal to Text
Replies
3
Views
527
_eNVy_
E
E
  • Solved
Macro to delete all rows
Replies
2
Views
447
Alex Blakenburg
A
H
  • Question
Adjust an existing formula based on most recently added column and prior month end date.
Replies
1
Views
105
healeydm
H
K
  • Solved
Simple implementation question
Replies
5
Views
420
Katolux
K

Forum statistics

Threads
1,214,979
Messages
6,122,552
Members
449,088
Latest member
davidcom

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