Macro Freezes

[MHamid]

Hello,



My code works, but it hangs for a long time every now and then. It will freeze and stop working. I will end up having to shut down excel and retry multiple times until it works. Can someone please look at my code and let me know if it’s something in my code that is causing to hang and freeze until I have it shut down excel?

Sub BulkUploadTemplate()

'Macro to populate Bulk Upload Template

'Created by Miriam Hamid - Completed 6/24/19



'Turn Off ScreenUpdating

Application.ScreenUpdating = False

Application.AskToUpdateLinks = False



Call MoveYellow

Call CopyData

Call RemainingColumns

Call CleanUp



'Turn On ScreenUpdating

Application.ScreenUpdating = True



'Message box Alerting Process is Complete

MsgBox "Complete"



End Sub



Sub MoveYellow()

'Macro to populate Bulk Upload Template

'Created by Miriam Hamid 6/11/2019





'Define Variables

Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, s4 As Worksheet

Dim GetMeOut As Label, GetMeOut2 As Label

Dim J As Long, k As Long, n As Long, i As Long, o As Long, l As Long, J2 As Long

Dim LastCol As Long, LastCol2 As Long

Dim PDYear As Integer

Dim PPath As String

Dim PFileName As String

Dim filePath As String

Dim SourceWb As Workbook

Dim TargetWb As Workbook

Dim IsOpen As Boolean



'Set PDYear

'PDYear = Year(Date)

PDYear = 2020



'Set PathName

PPath = "\\namicgdfs\cpna_data_grp\IT RMO PBI\Audit and Control\ARR - Audit Files & Metrics\" & PDYear & " Audit Metrics" & "\" & PDYear & " Audit Plan\"



'Set FileName

PFileName = PDYear & "_IA_Plan_Gold_Copy" & ".xlsm"



'Set Workbooks

Set TargetWb = ThisWorkbook

filePath = PPath & PFileName



'Check if Audit Plan is Open

IsOpen = BookOpen(PFileName)



If IsOpen Then

Set SourceWb = Workbooks(PFileName)

'Set Worksheets

Set s1 = SourceWb.Sheets("Audit_Plan")

Set s3 = SourceWb.Sheets("AP_CancelledPostponed")

Else

Workbooks.Open Filename:=filePath, ReadOnly:=True

Set SourceWb = Workbooks(PFileName)

'Set Worksheets

Set s1 = SourceWb.Sheets("Audit_Plan")

Set s3 = SourceWb.Sheets("AP_CancelledPostponed")

End If



'Set Worksheets

Set s2 = TargetWb.Sheets("Sheet2") 'Bulk Upload Template

Set s4 = TargetWb.Sheets("owssvr") 'Bulk Upload Template



'Set Variables

lRow = s4.Cells(Rows.Count, "C").End(xlUp).Row



'Turn Off Alerts

Application.DisplayAlerts = False

Application.AskToUpdateLinks = False



'Show Levels in Audit Plan

With s1

ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2

End With



'Find Highlighted Rows from S1 and Copy into S2

LastCol = s1.Cells.Find(What:="*", After:=[F6], _

SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious).Column



If IsEmpty(s2.Range("A1")) Then

i = 1

Else

i = s2.Cells(Rows.Count, "A").End(xlUp).Row + 1

End If

J = s1.Cells(Rows.Count, "A").End(xlUp).Row

For n = 1 To J

For k = 1 To LastCol

If s1.Cells(n, k).Interior.ColorIndex = 6 Then

s1.Cells(n, "A").EntireRow.Copy: s2.Cells(i, "A").pastespecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

i = i + 1

GoTo GetMeOut

End If

Next



GetMeOut:

Next



'Find Highlighted Rows from S3 and Copy into S2

LastCol2 = s3.Cells.Find(What:="*", After:=[F6], _

SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious).Column



If IsEmpty(s2.Range("A1")) Then

i = 1

Else

i = s2.Cells(Rows.Count, "A").End(xlUp).Row + 1

End If

J2 = s3.Cells(Rows.Count, "A").End(xlUp).Row

For o = 1 To J2

For l = 1 To LastCol2

If s3.Cells(o, l).Interior.ColorIndex = 6 Then

s3.Cells(o, "A").EntireRow.Copy: s2.Cells(i, "A").pastespecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

i = i + 1

GoTo GetMeOut2

End If

Next



GetMeOut2:

Next



'Turn On Alerts

Application.DisplayAlerts = True



'Reset the Clipboard

Application.CutCopyMode = False



'Hide Levels in Audit Plan

With s1

ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1

End With



'Close Audit Plan File

Workbooks(PFileName).Close savechanges:=False



'Activate Bulk Upload Spreadsheet

s2.Activate



End Sub



Sub CopyData()

'Macro To Copy Data from Sheet 2 into Bulk Upload Template

'Create by Miriam Hamid 6/18/2019



'Define Variables

Dim headers As Collection

Dim msg As String

Dim s1 As Worksheet, s2 As Worksheet

Dim header As Variant

Dim source As Range

Dim dest As Range



'Set Variables

Set headers = GetHeaders



'Set Worksheets

Set s1 = ThisWorkbook.Sheets("Sheet2") 'source worksheet

Set s2 = ThisWorkbook.Sheets("owssvr") 'destination worksheet



'Turn Off Screen Updating

Application.ScreenUpdating = False

Application.AskToUpdateLinks = False



'Copy Data from s1 and Paste into s2

For Each header In headers

Set source = FindHeaderRange(s1, header)

If source Is Nothing Then

'msg = BuildMessage(msg, s1, header)

'dest.Interior.Color = vbRed

Else

Set dest = FindHeaderRange(s2, header)

If dest Is Nothing Then

'msg = BuildMessage(msg, s2, header)

Else

s1.Range(source.Offset(1), s1.Cells(Rows.Count, source.Column).End(xlUp)).Copy s2.Cells(dest.Column).End(xlUp)(3)

End If

End If

Next



ExitSub:



'Reset the Clipboard

Application.CutCopyMode = False



'Turn On Screen Updating

Application.ScreenUpdating = True



End Sub



Sub RemainingColumns()

'Macro To Enter Data for Remaining Columns

'Create by Miriam Hamid 6/24/2019



''Define Variables

Dim s1 As Worksheet, s2 As Worksheet

Dim lRow As Long

Dim TargetWb As Workbook

Dim SourceWb As Workbook

Dim PDYear As Integer

Dim PPath As String

Dim PFileName As String

Dim filePath As String



'Set PDYear

'PDYear = Year(Date)

PDYear = 2020



'Set PathName

PPath = "\\namicgdfs\cpna_data_grp\IT RMO PBI\Audit and Control\ARR - Audit Files & Metrics\" & PDYear & " Audit Metrics" & "\" & PDYear & " Audit Plan" & "\" & "SharePoint\"



'Set FileName

PFileName = "AIF_Data_Reporting_View.xlsb"



'Set Workbooks

Set TargetWb = ThisWorkbook

filePath = PPath & PFileName

Set SourceWb = Workbooks.Open(filePath)



'Set Worksheets

Set s1 = SourceWb.Sheets("owssvr") 'SharePoint Data File

Set s2 = TargetWb.Sheets("owssvr") 'Bulk Upload Template



'Set Variables

lRow = s2.Cells(Rows.Count, "C").End(xlUp).Row



'Turn Off Screen Updating

Application.ScreenUpdating = False

Application.AskToUpdateLinks = False



'Activate this workbook

s2.Activate



'Hardcode Data for AIF Audit Status, Item Type, and Path; Copy Formula to last row of data

'Range("BD3:BD" & lRow).Formula = "OPEN"

'Range("BE3:BE" & lRow).formula = "Item"

'Range("BF3:BF" & lRow).formula = "sites/EIRMIA/Lists/AIF Data OT"



'Formula to Add Data for ID, Year, Report Published, Risk and Control Matrix (RCM) ; Copy Formula to last row of data

With Range("A3:A" & lRow)

.NumberFormat = "General"

.FORMULA = "=IFNA(IF(RC[1]=0,"""",RC[1]),"""")"

End With

With Range("E3:E" & lRow)

.NumberFormat = "General"

.FORMULA = "=YEAR(TODAY())"

End With

With Range("M3:M" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(RC[-1]=""Completed"",""Report Published"","""")"

End With

With Range("P3:P" & lRow)

.NumberFormat = "General"

.FORMULA = "=IFNA(IF(VLOOKUP(RC[-13],[AIF_Data_Reporting_View.xlsb]owssvr!C3:C27,25,0)<>"""",VLOOKUP(RC[-13],[AIF_Data_Reporting_View.xlsb]owssvr!C3:C27,25,0),""TO BE CONFIRMED""),""TO BE CONFIRMED"")"

End With



'Parse Hierarchy

With Range("Z3:Z" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(RC[-1]=""Non-O&T"",VLOOKUP(RC[-23],Sheet2!C6:C46,41,0),"""")"

End With

With Range("AA3:AA" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IF(RC[-1]=""Shared Non-O&T"",VLOOKUP(RC[-24],Sheet2!C6:C49,44,0),"""")=0,"""",IF(RC[-1]=""Shared Non-O&T"",VLOOKUP(RC[-24],Sheet2!C6:C49,44,0),""""))"

End With

With Range("AB3:AB" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IF(RC[-3]=""O&T Area"",VLOOKUP(RC[-25],Sheet2!C6:C46,41,0),"""")=0,"""",IF(RC[-3]=""O&T Area"",VLOOKUP(RC[-25],Sheet2!C6:C46,41,0),""""))"

End With

With Range("AC3:AC" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IF(RC[-1]=""Operations"",VLOOKUP(RC[-26],Sheet2!C6:C47,42,0),"""")=0,"""",IF(RC[-1]=""Operations"",VLOOKUP(RC[-26],Sheet2!C6:C47,42,0),""""))"

End With

With Range("AD3:AD" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IF(RC[-2]=""Other O&T Units"",VLOOKUP(RC[-27],Sheet2!C6:C47,42,0),"""")=0,"""",IF(RC[-2]=""Other O&T Units"",VLOOKUP(RC[-27],Sheet2!C6:C47,42,0),""""))"

End With

With Range("AE3:AE" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IF(RC[-3]=""Technology"",VLOOKUP(RC[-28],Sheet2!C6:C47,42,0),"""")=0,"""",IF(RC[-3]=""Technology"",VLOOKUP(RC[-28],Sheet2!C6:C47,42,0),""""))"

End With

With Range("AF3:AF" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IF(RC[-3]=""Multi O&T Businesses"",VLOOKUP(RC[-29],Sheet2!C6:C49,44,0),"""")=0,"""",IF(RC[-3]=""Multi O&T Businesses"",VLOOKUP(RC[-29],Sheet2!C6:C49,44,0),""""))"

End With

With Range("AG3:AG" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IF(RC[-5]=""Operations"",VLOOKUP(RC[-30],Sheet2!C6:C49,44,0),"""")=0,"""",IF(RC[-5]=""Operations"",VLOOKUP(RC[-30],Sheet2!C6:C49,44,0),""""))"

End With

With Range("AH3:AH" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IF(RC[-3]=""Multi O&T Businesses"",VLOOKUP(RC[-31],Sheet2!C6:C49,44,0),"""")=0,"""",IF(RC[-3]=""Multi O&T Businesses"",VLOOKUP(RC[-31],Sheet2!C6:C49,44,0),""""))"

End With

With Range("AI3:AI" & lRow)

.NumberFormat = "General"

.FORMULA = "=IFNA(IF(VLOOKUP(RC[-32],[AIF_Data_Reporting_View.xlsb]owssvr!C3:C62,60,0)=0,"""",VLOOKUP(RC[-32],[AIF_Data_Reporting_View.xlsb]owssvr!C3:C62,60,0)),"""")"

End With



'Copy PasteSpecial Values

Range("Table_owssvr7").Copy

Range("Table_owssvr7").pastespecial Paste:=xlPasteValues

Application.CutCopyMode = False



'Activate Cell

Range("A3").Select



'Close SharePoint File

Workbooks(PFileName).Close savechanges:=False



'Turn Off Screen Updating

Application.ScreenUpdating = True

Application.AskToUpdateLinks = True





End Sub



Sub CleanUp()

'Macro to update Audit Status

'Created by Miriam Hamid 6/24/2019





'Define Variables

Dim s1 As Worksheet

Dim TargetWb As Workbook



'Set Workbooks

Set TargetWb = ThisWorkbook



'Set Worksheets

Set s1 = TargetWb.Sheets("owssvr") 'Bulk Upload Template



'Set Variables

lRow = s1.Cells(Rows.Count, "C").End(xlUp).Row



'Turn Off Screen Updating

Application.ScreenUpdating = False

Application.AskToUpdateLinks = False



'Update Audit Status

With s1

With Range("L3:L" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(IFNA(MATCH(RC[-9],[2020_IA_Plan_Gold_Copy.xlsm]AP_CancelledPostponed!C6,0),"""")<>"""",""Removed"",IF(VLOOKUP(RC[-9],Sheet2!C6:C18,13,0)=""In Progress"",VLOOKUP(RC[-9],[2020_IA_Plan_Gold_Copy.xlsm]Check_WeeklyTracker!C1:C10,10,0),VLOOKUP(RC[-9],Sheet2!C6:C18,13,0)))"

.Copy

.pastespecial Paste:=xlPasteValues

End With

End With



'Reset the Clipboard

Application.CutCopyMode = False



'Find and Replace #

Cells.Replace What:="#", Replacement:="", LookAt:=xlPart, SearchOrder:= _

xlByColumns, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False



'Find and replace "Completed" and "In Progress" in Audit Status Column

Columns("L:L").Replace What:="Completed", Replacement:="Fieldwork Complete", _

LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat _

:=False, ReplaceFormat:=False

Columns("L:L").Replace What:="1-Planning", Replacement:="In-Planning", _

LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat _

:=False, ReplaceFormat:=False

Columns("L:L").Replace What:="0-Not Started", Replacement:="In-Planning", _

LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat _

:=False, ReplaceFormat:=False

Columns("L:L").Replace What:="2-Fieldwork", Replacement:="In-Fieldwork", _

LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat _

:=False, ReplaceFormat:=False

Columns("L:L").Replace What:="3-Reporting", Replacement:="In-Fieldwork", _

LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat _

:=False, ReplaceFormat:=False

Columns("L:L").Replace What:="N/A", Replacement:="In-Planning", _

LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat _

:=False, ReplaceFormat:=False



'Defining Item Type

With Range("BD3:BD" & lRow)

.NumberFormat = "General"

.FORMULA = "=IF(OR(RC[-44]=""FIELDWORK COMPLETE"",RC[-44]=""REMOVED""),""COMPLETE"",""OPEN"")"

.Copy

.pastespecial Paste:=xlPasteValues

End With



'Find and replace /

Columns("AA:AI").Replace What:="/", Replacement:=";", _

LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat _

:=False, ReplaceFormat:=False



'Update Region with ; at the beginning and end of text

Dim Cell As Range



For Each Cell In Range("Q:Q")

If InStr(1, Cell.Value, ";") <> 0 Then

Cell.Value = ";" & Cell.Value & ";"

End If

Next



'Find and Replace Regions

Columns("Q:Q").Select

Selection.Replace What:="North America", Replacement:="NA", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False

Selection.Replace What:="Asia Pacific", Replacement:="ASPAC", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False

Selection.Replace What:="APAC", Replacement:="ASPAC", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False

Selection.Replace What:="Mexico", Replacement:="MEX", LookAt:=xlPart, _

SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False

Selection.Replace What:=";LATAM;LATMex;", Replacement:=";LATAM;MEX;", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False

Selection.Replace What:=";LATMex;MEX;", Replacement:=";MEX;", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False

Selection.Replace What:=";MEX;MEX;", Replacement:=";MEX;", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False

Selection.Replace What:="NAM", Replacement:="NA", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False

Selection.Replace What:=";NA;NA;", Replacement:=";NA;", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False



'Find and Replace UK(GB)

Columns("R:R").Select

Selection.Replace What:="UK(GB)", Replacement:="UK(UK)", LookAt:= _

xlPart, SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _

ReplaceFormat:=False



'Reset Selection

Range("A2").Select



'Turn On Screen Updating

Application.ScreenUpdating = True

Application.AskToUpdateLinks = True



End Sub

Function BookOpen(Bk As String) As Boolean



'Declare Variable

Dim T As Excel.Workbook



'Clears any errors

Err.Clear



'If code runsinto error, it skips it and continues

On Error Resume Next



'Set Variables

Set T = Application.Workbooks(Bk)



'If T is open, then T will hold the workbook object and therefore will NOT be Nothing

BookOpen = Not T Is Nothing



'Clears any errors

Err.Clear

On Error GoTo 0



End Function



Private Function GetHeaders() As Collection

Dim result As New Collection

With result

.Add "ID"

.Add "SharePoint List ID"

.Add "Audit Number"

.Add "Audit Title - NEW"

.Add "Year"

.Add "Month"

.Add "Plan Report Publication Quarter"

.Add "Business per IA"

.Add "Sub-Business per IA"

.Add "Final Audit Report Date"

.Add "Audit Report Number"

.Add "Audit Status"

.Add "Report Published"

.Add "Rating-Report Published"

.Add "Name of Published Report"

.Add "Risk and Control Matrix (RCM)"

.Add "Regional Area per Internal Audit"

.Add "Country per Internal Audit"

.Add "Legal Vehicle - Citibank"

.Add "Legal Vehicle - CTI Legal Vehicle"

.Add "Legal Vehicle - CGM O&T Legal Vehicle"

.Add "Legal Vehicle - Other"

.Add "Audit Type"

.Add "Region"

.Add "Sector"

.Add "Audit Ownership (1)"

.Add "Audit Ownership (2-Non OT)"

.Add "Audit Ownership (3-SH Non-OT) 2"

.Add "Audit Ownership (3-OT)"

.Add "Audit Ownership (4-OT Ops)"

.Add "Audit Ownership (4-OT Other)"

.Add "Audit Ownership (4-OT Tech)"

.Add "Audit Ownership (5-OT Multi OT Ops)"

.Add "Audit Ownership (5-OT Ops Multi Ops)"

.Add "Audit Ownership (5-OT TECH Multi Ops)"

.Add "Audit Ownership (6-Detailed)"

.Add "Hierarchy Note"

.Add "Information Security in Scope"

.Add "Continuity of Business in Scope"

.Add "Third Party Management in Scope"

.Add "End-User Computing in Scope"

.Add "Inter-Affiliate in Scope"

.Add "Project Management"

.Add "Data Management"

.Add "ISSUES - IBAM - 1"

.Add "ISSUES - IBAM - 2"

.Add "ISSUES - IBAM - 3"

.Add "ISSUES - IBAM - 4"

.Add "ISSUES - IBAM - 5"

.Add "ISSUES - IBAM - TOT"

.Add "ISSUES - TOTAL - 1"

.Add "ISSUES - TOTAL - 2"

.Add "ISSUES - TOTAL - 3"

.Add "ISSUES - TOTAL - 4"

.Add "ISSUES - TOTAL - 5"

.Add "ISSUES - TOTAL - TOT"

.Add "AIF Audit Review Status"

.Add "Item Type"

.Add "Path"

End With



Set GetHeaders = result



End Function



Private Function FindHeaderRange(ByVal ws As Worksheet, ByVal header As String) As Range

Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole)

End Function



'Private Function BuildMessage(ByVal currentMessage As String, ByVal ws As woksheeet, ByVal header As String) As String

' BuildMessage = currentMessage & vbLf & header & Space(1) & ws.Name

'End Function

Thank you

 

[CountTepes]

I notice that you are jumping out of if then condition and out of a for next loop using goto.

When you are in a for next loop, VBA has set up a stack, which it doesn't unload, if you jump out. The correct way to leave a for next loop early, is either to force the value of the looping variable to equal or exceed the last value, like this:

For X= 1 to 100
If x=20 then x=100
next

Or with an Exit For statement.

For X = 1 to 100
if X= 20 then Exit For
Next

What can happen if you quit without the stack unloading, is that more and more stack memory is used, until it runs out. Then the program crashes.

Tidy up your code like that and see if it helps.

 

[6StringJazzer]

I notice that you are jumping out of if then condition and out of a for next loop using goto.

When you are in a for next loop, VBA has set up a stack, which it doesn't unload, if you jump out. The correct way to leave a for next loop early, is either to force the value of the looping variable to equal or exceed the last value

Using a GoTo is a poor practice; we've known this since the 1960s. I agree you should not exit a For loop with GoTo. However, entering a For Loop does not push a stack frame. A stack frame is created when a Sub or Function is called. There is no new memory allocated for a For loop. Additionally, if you have, for example, a runaway recursive procedure, that will consume all available stack space but it doesn't result in a crash; it results in an "Out of stack space" error.

If you need to prematurely exit a For loop, I do not recommend changing the index value. An Exit For is better. Better yet is to use a Do While or Do Until if you have conditions for exit other than the index value.

What would concern me more is a GoTo that causes an entry into the middle of a For Loop, but that's not happening here.

Sometimes freezing behavior is caused by an infinite loop. However, the loops in this code are all For loops, and there appear to be no side effects that would cause them to become infinite.

Another issue (but I don't think this is causing your problem) is the use of ActiveSheet. You should explicitly qualify what sheet you want to reference rather than relying on what is active, unless a macro is truly intended to operate on any sheet that happens to be active at that moment.

As much as I appreciate the code tags, the code is not indented so is very difficult to read for structure, is very lengthy, and so complex that it can't be run without your file. I'll see if there's any further analysis I can do. I would suggest adding some debug code or checkpoints so you can determine how far it gets before it freezes/crashes to try to identify the point of failure.

 

[6StringJazzer]

In sub MoveYellow variable lRow is never declared, but set on line 78, and never used.

In sub CleanUp variable lRow is never declared, but set and used.

   'Check if Audit Plan is Open
   IsOpen = BookOpen(PFileName)

   If IsOpen Then
      Set SourceWb = Workbooks(PFileName)
      'Set Worksheets
      Set s1 = SourceWb.Sheets("Audit_Plan")
      Set s3 = SourceWb.Sheets("AP_CancelledPostponed")
   Else
      Workbooks.Open Filename:=filePath, ReadOnly:=True
      Set SourceWb = Workbooks(PFileName)
      'Set Worksheets
      Set s1 = SourceWb.Sheets("Audit_Plan")
      Set s3 = SourceWb.Sheets("AP_CancelledPostponed")
   End If

How can the Set in the Else part above work if PFileName is determined to be not open?

I don't see anything else in terms of coding structure that would cause a problem. Maybe there is something in your worksheet, like you mistakenly populate something in row 1,000,000 and then try to do a copy and paste of a million rows.