Edit a small code to remove error

[moonbreakker]

Hello,

Credit for the codes to Skywriter.

In attached sheet, macro2 (StatusMove) only has the issue. It runs fine IF and ONLY if all three entries (Delivered, Hold, Rejected) are present in column H. If any of the three is missing it gives 1004 with cells not found error.

I want it to run with any of the entries. And if H is blank, it can give message like Status is empty or something.

Any help will be greatly appreciated.

Option Explicit

Sub PopulateSheet2()
Dim ws1 As Worksheet, ws2 As Worksheet, arrModels, j As Long, c As Long, x As Long, suCount As Long, aCount As Long
Dim myAreas As Areas, y As Long
Set ws1 = Worksheets("Sheet1"): Set ws2 = Worksheets("Sheet2")

Application.ScreenUpdating = False

ws2.Range("A1").CurrentRegion.Offset(1).ClearContents

With ws2.Range("L1").CurrentRegion
    arrModels = .Offset(1).Resize(.Rows.Count - 1, .Columns.Count)
End With

With ws1.Range("A1").CurrentRegion
.Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlYes
    For j = LBound(arrModels) To UBound(arrModels)
        .AutoFilter 6, Criteria1:=arrModels(j, 1)
            c = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
            x = arrModels(j, 2) + arrModels(j, 3)
            suCount = WorksheetFunction.Min(c, x)
            Set myAreas = .Offset(1).Resize(.Rows.Count - 1, 6).SpecialCells(xlCellTypeVisible).Areas
           aCount = myAreas.Count
 
            For c = 1 To myAreas.Count
                If suCount = 0 Then GoTo 1
                If myAreas(c).Rows.Count <= suCount Then
                    myAreas(c).Rows.Copy ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1)
                    suCount = suCount - myAreas(c).Rows.Count
                Else
                    For x = 1 To suCount
                        myAreas(c).Rows(x).Copy ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1)
                        suCount = suCount - 1
                    Next x
                End If
            Next c
         
1          .AutoFilter

    Next j
End With
    With ws2
    
        x = .Cells(Rows.Count, "F").End(xlUp).Row
    
            If x < 2 Then Exit Sub
            y = 2
     For j = LBound(arrModels) To UBound(arrModels)
        If arrModels(j, 2) > 0 Then
            For c = 1 To arrModels(j, 2)
                 If arrModels(j, 1) = .Cells(y, 6) And y < x + 1 Then
                     .Cells(y, 7) = "READY FOR DELIVERY"
                    y = y + 1
                Else
                    Exit For
                 End If
            Next c
        End If
        
        If arrModels(j, 3) > 0 Then
            For c = 1 To arrModels(j, 3)
                If arrModels(j, 1) = .Cells(y, 6) And y < x + 1 Then
                    .Cells(y, 7) = "UP-COMING"
                     y = y + 1
                Else
                    Exit For
                End If
            Next c
        End If
       
     Next j
    
End With

Application.ScreenUpdating = True

End Sub

 Sub StatusMove()
 
 Dim ws1 As Worksheet, ws2 As Worksheet
 Dim arrFilterCriteria, r As Range, j As Long, rngFound As Range, rngData As Range
 Set ws1 = Worksheets("Sheet1"): Set ws2 = Worksheets("Sheet2")
  
  arrFilterCriteria = Array("DELIVERED", "REJECTED", "HOLD")
  
 Application.ScreenUpdating = False
 
 With ws2.Range("A1").CurrentRegion
 Set rngData = .Offset(1).Resize(.Rows.Count - 1, Columns.Count)
 
       For j = LBound(arrFilterCriteria) To UBound(arrFilterCriteria)
            .AutoFilter 8, Criteria1:=arrFilterCriteria(j)
                    For Each r In rngData.Columns(1).SpecialCells(xlCellTypeVisible)
                
                    If r.Value <> Empty Then
                        With ws1.Columns(1)
                            Set rngFound = .Find(r.Value)
                                If Not rngFound Is Nothing Then
                                    Range(rngFound, rngFound.Offset(, 5)).Delete Shift:=xlUp
                                End If
                        End With
                    End If
                Next r
                                
               .Offset(1).Copy Worksheets(arrFilterCriteria(j)).Cells(Worksheets(arrFilterCriteria(j)).Rows.Count, "A").End(xlUp).Offset(1)
               .Offset(1).ClearContents
               
1                    .AutoFilter
        Next j
             .Offset(1).Sort Key1:=.Range("A2")
 End With

 Application.ScreenUpdating = True

 End Sub

Thank you.