Filtering of data tables

[apope]

I was wondering if you guys could help me figure out how to pull the dates from the table below into two separate tables. I want the tables to be organized into:

Table 1: all "1" bedrooms that are "New" and their corresponding "Collected Rent" and "Move in" dates
Table 2: all "2" bedrooms that are "New" and their corresponding "Collected Rent" and "Move in" dates

# of Bedrooms	Renter's Status	Collected Rent	Move in
1	New	$922.63	6/1/2017
1	Occupied	$936.94	6/1/2014
2	Occupied	$953.39	8/1/2006
1	Vacant	$935.00	1/0/1900
2	Occupied	$1,050.82	11/1/2015
2	Occupied	$1,024.12	9/16/2015
1	Occupied	$860.61	9/1/2005
1	Occupied	$836.19	3/1/1998
1	Occupied	$845.46	4/1/1996
1	Occupied	$936.33	10/1/2004
2	Occupied	$1,003.83	9/17/2016
2	Occupied	$1,061.15	10/1/2010
1	New	$925.00	9/1/2017
1	Occupied	$914.02	10/1/1996
2	Occupied	$999.77	4/1/2016
2	Occupied	$1,056.00	8/1/2015
1	Occupied	$908.42	2/1/2016
2	Occupied	$1,046.58	9/1/2004
2	Occupied	$1,045.00	12/1/2016
1	Occupied	$936.33	4/1/2005
2	New	$1,035.00	8/1/2017
2	Occupied	$1,013.98	6/1/2016
1	Occupied	$934.92	12/1/2013
1	Occupied	$938.01	6/1/2015
2	New	$1,055.00	7/1/2017
2	Occupied	$982.88	8/1/2006
1	Occupied	$938.01	9/1/2015
1	Occupied	$941.41	10/15/2014

<tbody>
</tbody><colgroup><col><col><col><col></colgroup>

Many thanks!

 

[Truiz]

Change sheet names to match your own

Sub Tablez()
Dim lrow, iCntr, lrow2 As Long


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




lrow = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row


    For iCntr = lrow To 2 Step -1
    lrow2 = Sheets(2).Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
        If Cells(iCntr, "A").Value = 1 And Cells(iCntr, "B") = "New" Then
            Range(Cells(iCntr, "A"), Cells(iCntr, "D")).Copy Sheets("Open").Cells(lrow2 + 1, "A")
        End If
    Next
    
    For iCntr = lrow To 2 Step -1
    lrow2 = Sheets(3).Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
        If Cells(iCntr, "A") = 2 And Cells(iCntr, "B") = "New" Then
            Range(Cells(iCntr, "A"), Cells(iCntr, "D")).Copy Sheets("Closed").Cells(lrow2 + 1, "A")
            'Rows(iCntr).Delete
        End If
    Next
    
Application.CutCopyMode = False


With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
     .EnableEvents = True
End With
End Sub