See if this get you close. See attachment.
Sub ParseTable()
Dim WS As Worksheet
Dim WS2 As Worksheet
Dim A As Long
Dim LastRow As Long
Dim DestLR As Long
Dim Unique As New Collection
Dim FltAry(1 To 5) As String
Dim B As Long
Dim MyArray As Variant
Dim RngArea As Range, LCount As Long
Application.ScreenUpdating = False
Set WS = Worksheets(1)
With WS
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
MyArray = .Range("A2:C" & LastRow)
For A = 1 To UBound(MyArray)
On Error Resume Next
Unique.Add MyArray(A, 1), MyArray(A, 1)
On Error GoTo 0
Next
FltAry(1) = "<" & Date + 365
FltAry(2) = "<" & Date + 182
FltAry(3) = "<" & Date + 90
FltAry(4) = "<" & Date + 60
FltAry(5) = "<" & Date + 30
For A = 1 To Unique.Count
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WS2 = ActiveSheet
For B = 1 To 5
.AutoFilterMode = False
With .Range("A1:C" & LastRow)
.AutoFilter
.AutoFilter 1, Unique(A)
.AutoFilter 3, FltAry(B), xlAnd
'Determine is any rows are present.
For Each RngArea In .SpecialCells(xlCellTypeVisible).Areas
LCount = LCount + RngArea.Rows.Count
Next
If LCount > 1 Then
.SpecialCells(xlCellTypeVisible).Copy
With WS2
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValuesAndNumberFormats
.Range("A1").Select
DestLR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End If
End With
LCount = 0
Next
Next
.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
End Sub
Bookmarks