VBA suddenly started crashing excel with no changes from last working version. Please Help!

[jmorriso115]

Hi All,
I have a workbook of many pages and a VBA macro to compile data from all sheets (except some other report sheets)
Could anyone give this a once over and let me know if they see any glaring errors or opportunities to streamline? Any help would be greatly appreciated!

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="Placeholder", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function


Sub Masterlist_1_1()
        Dim sh As Worksheet, DestSh As Worksheet, ws As Worksheet
        Dim wb As Workbook
        Dim Last As Long, shLast As Long, StartRow As Long, r As Long, InvalidCount As Long, x As Long
        Dim CopyRng As Range, DelRng As Range, cell As Range, WDRng As Range, Grng As Range, Hrng As Range, Srng As Range, DRng As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Disable Display for Calculations
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Delete the sheet "Masterlist" if it exist
        Application.DisplayAlerts = False
            On Error Resume Next
                ActiveWorkbook.Worksheets("Masterlist").Delete
                    On Error GoTo 0
                        Application.DisplayAlerts = True
    'Add a worksheet with the name "Masterlist"
        Set DestSh = ActiveWorkbook.Worksheets.Add
            DestSh.Name = "Masterlist"
                'Fill in the start row
                    StartRow = 2
    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If IsError(Application.Match(sh.Name, Array(DestSh.Name, "TOTALS", "MW TOTALS", "Dominion"), 0)) Then
    'Copy header row, change the range if you use more columns
        If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
            sh.Range("A1:Q1").Copy DestSh.Range("A1")
        End If
    'Find the last row with data on the DestSh and sh
            Last = LastRow(DestSh)
            shLast = LastRow(sh)
        'If sh is not empty and if the last row >= StartRow copy the CopyRng
            If shLast > 0 And shLast >= StartRow Then
            'Set the range that you want to copy
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
                'Test if there enough rows in the DestSh to copy all the data
                    If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                        MsgBox "There are not enough rows in the Destination"
                            GoTo ExitTheSub:
                    End If
                'Copy Values and Paste to "Masterlist"
                    CopyRng.Copy
                        With DestSh.Cells(Last + 1, "A")
                            .PasteSpecial xlPasteValues
                                Application.CutCopyMode = False
                        End With
                'Copy Home Sheet Name into Col Q ("Developer")
                    DestSh.Cells(Last + 1, "Q").Resize(CopyRng.Rows.Count).Value = sh.Name
            End If
        End If
    Next
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Organization and Formatting of "Masterlist" sheet
        Application.GoTo DestSh.Cells(1)
    'Set Column Widths and Formats in the "Masterlist" sheet:
        'Owner Name as Text
            DestSh.Columns("A").ColumnWidth = 27
            DestSh.Columns("A").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Size (kW) as Number
            DestSh.Columns("B").ColumnWidth = 7.5
            DestSh.Columns("B").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Docket No. as Number
            DestSh.Columns("C").ColumnWidth = 9
            DestSh.Columns("C").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Registered as Date
            DestSh.Columns("D").ColumnWidth = 10
            DestSh.Columns("D").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "mm/dd/yyyy"
        'Accepted As Date
            DestSh.Columns("E").ColumnWidth = 10
            DestSh.Columns("E").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "mm/dd/yyyy"
        'TAT as Number
            DestSh.Columns("F").ColumnWidth = 3.25
            DestSh.Columns("F").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Utility as Text
            DestSh.Columns("G").ColumnWidth = 7.5
            DestSh.Columns("G").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'County as Text
            DestSh.Columns("H").ColumnWidth = 8.5
            DestSh.Columns("H").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'NMTC as Text
            DestSh.Columns("I").ColumnWidth = 6.5
            DestSh.Columns("I").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Location as Text
            DestSh.Columns("J").ColumnWidth = 40
            DestSh.Columns("J").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Withdrawn as Date
            DestSh.Columns("K").ColumnWidth = 10
            DestSh.Columns("K").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "mm/dd/yyyy"
        'Constructed as Text
            DestSh.Columns("L").ColumnWidth = 9
            DestSh.Columns("L").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Sold Date as Date
            DestSh.Columns("M").ColumnWidth = 10
            DestSh.Columns("M").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "mm/dd/yyyy"
        'Sold To As Text
            DestSh.Columns("N").ColumnWidth = 6
            DestSh.Columns("N").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Purchase Date as Date
            DestSh.Columns("O").ColumnWidth = 10
            DestSh.Columns("O").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "mm/dd/yyyy"
        'Purchased From as Text
            DestSh.Columns("P").ColumnWidth = 8
            DestSh.Columns("P").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
        'Developer as Text
            DestSh.Columns("Q").ColumnWidth = 8.15
            DestSh.Columns("Q").Resize(DestSh.Rows.Count - 1, 1).Offset(1, 0).NumberFormat = "General"
'Find and Remove Blank Rows
        With DestSh
            For r = 2 To .UsedRange.Rows.Count
            'Check for blanks in Size, Docket No. and Location
                If LenB(.Cells(r, 2)) = 0 And LenB(.Cells(r, 3)) = 0 And LenB(.Cells(r, 10)) = 0 Then
                    If DelRng Is Nothing Then Set DelRng = .Cells(r, 1) Else Set DelRng = Union(DelRng, .Cells(r, 1))
                    End If
            Next
                If Not DelRng Is Nothing Then DelRng.EntireRow.Delete
        End With
'Tidy Up Resulting Table
    'Set Borders for UsedRange
        ActiveSheet.UsedRange.Borders.LineStyle = xlContinuous
        'Clear Cell Color
            ActiveSheet.UsedRange.Interior.Color = xlNone
            'Color Header Row (Go Heels!)
                DestSh.Rows(1).Interior.Color = RGB(123, 175, 212)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Identify Withdrawn and Missing Data Rows
'Find and Strike Withdrawn Sites
    With DestSh
        'For all rows except Headers
            For r = 2 To DestSh.UsedRange.Rows.Count
            'If any value in Withdrawn Column
                If LenB(.Cells(r, 11)) > 0 Then
                'Set Range for Withdrawn Rows
                    If WDRng Is Nothing Then Set WDRng = .Cells(r, 1) Else Set WDRng = Union(WDRng, .Cells(r, 1))
                    'When Withdrawn Fill Accepted and TAT with "N/A"
                        If Not WDRng Is Nothing Then WDRng.Columns("E:F").Value = "N/A"
                        'Strikethrough Withdrawn Rows
                        If Not WDRng Is Nothing Then WDRng.EntireRow.Font.Strikethrough = True
                    End If
            Next
    End With
'Check for rows missing County/Utility Data
    'Check for Individual Blanks In Col. G
        With DestSh
            For r = 2 To DestSh.UsedRange.Rows.Count
                If LenB(.Cells(r, 7)) = 0 Then
                    If Grng Is Nothing Then Set Grng = .Cells(r, 1) Else Set Grng = Union(Grng, .Cells(r, 1))
                    'Set Color
                        If Not Grng Is Nothing Then Grng.EntireRow.Interior.ColorIndex = 22
                    End If
            Next
        End With
    'Check for Individual Blanks In Col. H
        With DestSh
            For r = 2 To ActiveSheet.UsedRange.Rows.Count
                If LenB(.Cells(r, 8)) = 0 Then
                    If Hrng Is Nothing Then Set Hrng = .Cells(r, 1) Else Set Hrng = Union(Hrng, .Cells(r, 1))
                    'Set Color
                        If Not Hrng Is Nothing Then Hrng.EntireRow.Interior.ColorIndex = 17
                    End If
            Next
        End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
ExitTheSub:
'Return to Normal
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[NdNoviceHlp]

As an aside U may want to consider adjusting this instead of using "find"...

With Sheets("Sheet1")
LastCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column()
LastRow = .Cells(.Cells.Rows.Count, "A").End(xlUp).Row()
End With

I'm pretty sure deleting sheets and then adding sheets with the same name makes everything pretty unstable. Maybe just clear the contents of the used range of "master sheet" instead of adding/removing the sheet. HTH. Dave