I found this fix on another site. Fix is in red.

'
Application.ScreenUpdating = False

Application.DisplayAlerts = False
Sheets("Refunds Due").Activate
    Dim WS As Worksheet
    Dim sht As Worksheet
    Dim strtRow As Long
    Dim rng As Range
    
    strtRow = 3 'set it to the row where you want to start it from
    
    Set sht = Sheets("Refunds Due")
    Set rng = sht.Range("A1")
     
     'clearing contents here :
     
     sht.Cells.ClearContents
     
     For Each WS In Worksheets
        If WS.Visible = xlSheetVisible And WS.Tab.ColorIndex <> 1 Then
     
            If WS.Name <> "Resident List by Unit" And WS.Name <> "Refunds Due" Then
                WS.Range("d11").Copy
                rng.Offset(strtRow, 0).PasteSpecial xlPasteValues
                
                WS.Range("b3").Copy
                rng.Offset(strtRow, 1).PasteSpecial xlPasteValues
                
                WS.Range("b6").Copy
                rng.Offset(strtRow, 2).PasteSpecial xlPasteValues
                
                WS.Range("d14").Copy
                rng.Offset(strtRow, 3).PasteSpecial xlPasteValues
                
                strtRow = strtRow + 1
            End If
        End If
     Next WS
     




    
    
    Range("D4").Select
    Selection.ClearContents
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "CONTRACT ENDED"
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "RESIDENT"
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "UNIT"
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "AMOUNT DUE"
    Columns("A:D").Select
    Columns("A:D").EntireColumn.AutoFit
    Rows("1:3").Select
    Selection.Delete Shift:=xlUp
    Cells.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
        , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal
    Range("A1").Select
    Range("A1:D1").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    
'Loop Code
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'We use the ActiveSheet but you can replace this with
    'Sheets("MySheet")if you want
    With ActiveSheet

        'We select the sheet so we can change the window view
        .Select

        'If you are in Page Break Preview Or Page Layout view go
        'back to normal view, we do this for speed
        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView

        'Turn off Page Breaks, we do this for speed
        .DisplayPageBreaks = False

        'Set the first and last row to loop through
        Firstrow = .UsedRange.Cells(1).Row
        Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

        'We loop from Lastrow to Firstrow (bottom to top)
        For Lrow = Lastrow To Firstrow Step -1

            'We check the values in the A column in this example
            With .Cells(Lrow, "A")

                If Not IsError(.Value) Then

                   If IsEmpty(.Value) Then .EntireRow.Delete
                    'This will delete each row with an empty value
                    'in Column A, case sensitive.

                End If

            End With

        Next Lrow




    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    
    Application.ScreenUpdating = True
End With

End Sub