Copy each filtered location by date to another sheet

Arshmaan

New member
Joined
Oct 20, 2011
Messages
10
Reaction score
0
Points
0
Location
Pakistan
Excel Version(s)
2007, 2016
Hello all,

I am filtering the data of my worksheet date by date (one by one), i want to copy every filtered entry in another sheet... i am attaching my worksheet from which you can see how i filter this data date by date.. but i want the whole month data in new sheet.. please help
 

Attachments

  • Tracking Report.xls
    185.5 KB · Views: 54
yeah ken my data is filtered i said i want to copy the filtered data Date by Date

for example manually i filter by date 1 and copy then paste to a new sheet
then by date 2 and copy and so oonn

i want to do this by VBA
 
Hi Arshmaan,

Sorry for the late reply here. Busy time of year. Try this out and see if it works for you:

Code:
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
 
Back
Top