Sub CopyDatesToNewSheet()
Dim ary() As Variant
Dim lDates As Long
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim rngDates As Range
Dim cl As Range
'Turn off screen flashing
Application.ScreenUpdating = False
'Record sheet to copy from
Set wsSource = ActiveSheet
With wsSource
'Work out how many dates need to be extracted
Set rngDates = .Range("D5:D" & .Range("D4").End(xlDown).Row)
.Range("E2").Formula = "=SUM(IF(FREQUENCY(" & rngDates.Address & "," & rngDates.Address & ")>0,1))"
lDates = .Range("E2").Value
'Read all dates into an array
ReDim ary(lDates - 1)
lDates = 0
For Each cl In rngDates
'Add date to array if not already there
If Not InArray(cl.Value, ary()) Then
ary(lDates) = cl.Value
lDates = lDates + 1
End If
Next cl
'Filter each record and copy records to new worksheet
.Rows("4:4").AutoFilter
For lDates = 0 To UBound(ary())
'Add new worksheet
Set wsTarget = ThisWorkbook.Worksheets.Add
wsTarget.Name = Format(ary(lDates), "yyyy-mm-dd")
wsSource.Rows(4).Copy
wsTarget.Rows(4).PasteSpecial Paste:=xlPasteAll
'Filter records on Source sheet
With .Rows("4:4")
.AutoFilter
.AutoFilter Field:=4, Operator:=xlFilterValues, Criteria2:=Array(2, ary(lDates))
End With
'Copy records
.Range("A5:" & .Range("A5").End(xlToRight).End(xlDown).Address).SpecialCells(xlCellTypeVisible).Copy
wsTarget.Range("A5").PasteSpecial Paste:=xlPasteAll
Next lDates
'Turn off Autofilter
.AutoFilterMode = False
End With
End Sub
Private Function InArray(data As Variant, ary() As Variant) As Boolean
Dim lAryItems As Long
For lAryItems = 0 To UBound(ary())
If ary(lAryItems) = data Then
InArray = True
Exit Function
End If
Next lAryItems
End Function