Buggy VBA Project. Streamlining/Trouble Shooting Help Please!

[jmorriso115]

Hi,
I have a database with worksheets for multiple companies and am trying to consolidate them into one masterlist, as well as run a couple other reports. I believe I have the reports working as intended but am experiencing very long processing times in running the masterlist generator. Does anyone have suggestions for debugging/streamlining or reducing redundancies for the following code? I've tried to comment as much as possible to make my intentions clear. Any help would be greatly appreciated!
Thanks!!!
Jim

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, i 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").UsedRange.Cells.Clear
                    On Error GoTo 0
                        Application.DisplayAlerts = True
    'DestSh is sheet with the name "Masterlist"
        Set DestSh = ActiveWorkbook.Worksheets("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 = 4.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, 3)) = 0 And LenB(.Cells(r, 4)) = 0 And LenB(.Cells(r, 7)) = 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
        DestSh.UsedRange.Borders.LineStyle = xlContinuous
        'Clear Cell Color
            DestSh.UsedRange.Interior.Color = xlNone
            'Color Header Row (Go Heels!)
                DestSh.Rows(1).Interior.Color = RGB(123, 175, 212)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Identify Rows with Special or Missing Data
'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"
                        'Would like line above not to replace dates if they are present
                        '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

 

[steve the fish]

Instead of all those loops at the end id consider using an autofilter. Heres some example code:

With ActiveSheet
    If .AutoFilterMode Then .AutoFilterMode = False
    x = .Range("A" & .Rows.Count).End(xlUp).Row
    With .Range("A1:A" & x)
        .AutoFilter
        .AutoFilter Field:=1, Criteria1:=1
        If .SpecialCells(xlCellTypeVisible).Count > 1 Then
            .Offset(1, 0).Resize(x - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End If
    End With
    .AutoFilterMode = False
End With