Sub GetZeroRows()
Dim ZeroRows As Range
Dim MyTable As Range
Dim MyRange As Range
Dim NewSheet As Worksheet
Dim c As Range
With Application
.ScreenUpdating = False 'Makes the macro run faster
.EnableEvents = False 'Disables event macros
End With
With Sheet1 'Sets the sheet where the original values are found
Set MyTable = .Range("A1:H5000") 'Sets the table to copy values from
Set MyRange = Intersect(MyTable.EntireRow, .Range("P:P")) 'Sets the range to look the values from
Set ZeroRows = Find_Range(0, MyRange, xlValues, xlWhole, False) 'Looks for matching values
If Not ZeroRows Is Nothing Then
Set NewSheet = Worksheets.Add(After:=Sheets(Sheets.Count)) 'Adds a new sheet
With NewSheet
'Writes the table headers:
.Cells(.Rows.Count, 1).End(xlUp).Resize(1, MyTable.Columns.Count).Value = MyTable.Rows(1).Value
'Loops through the ZeroRows to write the values
For Each c In ZeroRows
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(1, MyTable.Columns.Count).Value = Intersect(c.EntireRow, MyTable).Value
Next c
End With
End If
End With
'Restore original settings:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function Find_Range(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Range
Dim c As Range
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
If IsMissing(MatchCase) Then MatchCase = False
With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Set Find_Range = c
firstAddress = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Function
