Results 1 to 4 of 4

Thread: Copy each filtered location by date to another sheet

  1. #1

    Copy each filtered location by date to another sheet



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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
    Attached Files Attached Files

  2. #2
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,087
    Articles
    79
    Blog Entries
    14
    I'm not sure I follow... it looks like you already have the data filtered by month?
    Ken Puls, FCPA, FCMA, MS MVP (Excel)

    Master your data with Power Query: Purchase your copy of my book M is for Data Monkey today!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

  3. #3
    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

  4. #4
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,087
    Articles
    79
    Blog Entries
    14
    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
    Ken Puls, FCPA, FCMA, MS MVP (Excel)

    Master your data with Power Query: Purchase your copy of my book M is for Data Monkey today!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •