Filter data and copy relevant data to new worksheets RRS feed

  • Question

  • Can someone please help with this coding? I would like to do mutliple fixes to this...first, I would like it to create a new worksheet on its without having to put the code of where to paste the data. Second, when its done searching for value = A in this code and I run the "B" macro it pastes the revelant data in the next column that it finished copy from in the "A" macro so for example if all relevant A data was 200 lines then when I run the B macro it starts to paste in column 201 I would like it to always paste in column 2. If you could help me I'd really appreciate it.

    Sub Altoona()
    Dim r As Long, endRow As Long, pasteRowIndex As Long

    endRow = 20000 ' of course it's best to retrieve the last used row number via a function
    pasteRowIndex = 2

    For r = 1 To endRow 'Loop through sheet1 and search for your criteria

        If Cells(r, Columns("E").Column).Value = "A" Then 'Found

                'Copy the current row

                'Switch to the sheet where you want to paste it & paste

                'Next time you find a match, it will be pasted in a new row
                pasteRowIndex = pasteRowIndex + 1

               'Switch back to your table & continue to search for your criteria
                Sheets("Total Detail").Select
        End If
    Next r

    End Sub

    Friday, July 22, 2016 3:51 PM

All replies

  • Looping is a slow process - this code will create a sheet for every unique value in column E, and copy all the corresponding values to those sheets using filtering.

    Sub Altoona2()
        Dim endRow As Long
        Dim sh As Worksheet
        Dim shtT As Worksheet
        Dim rF As Range
        Dim c As Range
        Set sh = Sheets("Total Detail")
        ' of course it's best to retrieve the last used row number
        endRow = sh.Cells(sh.Rows.Count, "E").End(xlUp).Row
        'But we're not going to loop through every row
        'First we find the unique values - assumes that headers are in row 1
        sh.Range("E1:E" & endRow).AdvancedFilter Action:=xlFilterCopy, copytorange:=sh.Cells(endRow + 4, "E"), Unique:=True
        Set rF = sh.Range(sh.Cells(endRow + 5, "E"), sh.Cells(sh.Rows.Count, "E").End(xlUp))
        'Loop through the unique values
        For Each c In rF
            'Delete the worksheet if it exists already
            Application.DisplayAlerts = False
            On Error Resume Next
            On Error GoTo 0
            Application.DisplayAlerts = True
            'Make the new workhseet
            Set shtT = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            shtT.Name = c.Value
            'Find the values for the new worksheet
            With sh.Range("E1:E" & endRow)
                .AutoFilter field:=1, Criteria1:=c.Value
                .EntireRow.Copy shtT.Range("A1")
            End With
        Next c
        'Clean up
        sh.Range("E1:E" & endRow).AutoFilter
        rF.Offset(-1).Resize(rF.Rows.Count + 1).Clear
    End Sub

    Friday, July 22, 2016 5:18 PM