copy rows with certain value dynamically

[gauti]

I have a sheet with 10 columns. In column A the values can be anything but are often repeated. I want to select all the rows having the same value in column A to be copied and pasted in a new sheet(preferably with the sheet name as the column A value). I know how to set the criteria if the cell values in A are pre defined.. In my case they keep changing. for example if criteria to sort is known as 0517 i can do this..But i dont know all the values in column A to use this code multiple times for each value
Cells.AutoFilter
Cells.AutoFilter Field:=2, Criteria1:="0517"
Range("A2:J" & LR).SpecialCells(xlCellTypeVisible).Select
Range("A2:J" & LR).Copy
Sheets(0517).Activate
Cells(ALR, 1).Activate
ActiveSheet.Paste
Sheets(sheet1).Activate
Cells.AutoFilter
End Sub

 

[JLGWhiz]

See if this works for you

Sub copyDups()
Dim sh As Worksheet, lr As Long
Set sh = ActiveSheet
lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
With sh
    .Range("A1:A" & lr).AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 1), True
    For Each c In Cells(lr + 2, 1).CurrentRegion.Offset(1)
        If Application.CountIf(.Range("A2:A" & lr), c.Value) > 1 Then
            Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = c.Value
            .Range("A1:J" & lr).AutoFilter 1, c.Value
            .Range("A2:J" & lr).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp)(2)
            .AutoFilterMode = False
        End If
    Next
    .Cells(lr + 2, 1).CurrentRegion.ClearContents
End With
End Sub

 

[gauti]

See if this works for you

Sub copyDups()
Dim sh As Worksheet, lr As Long
Set sh = ActiveSheet
lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
With sh
    .Range("A1:A" & lr).AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 1), True
    For Each c In Cells(lr + 2, 1).CurrentRegion.Offset(1)
        If Application.CountIf(.Range("A2:A" & lr), c.Value) > 1 Then
            Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = c.Value
            .Range("A1:J" & lr).AutoFilter 1, c.Value
            .Range("A2:J" & lr).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp)(2)
            .AutoFilterMode = False
        End If
    Next
    .Cells(lr + 2, 1).CurrentRegion.ClearContents
End With
End Sub

this is great,thank so much for your help...however this gives an issue incase of empty cells..how do i fix that..i mean if the cell in column A is blank,may be add a sheet called blank and copy the contents there..also i need to do this analysis on column C, i changed that in your code but its giving me error in line-Range("A2:J" & lr).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp)(2)
No cells found when i am trying to copy from column A onwards

 

[JLGWhiz]

...however this gives an issue incase of empty cells..how do i fix that..

I don't know what you mean by this. The filters do now allow blank cells. You need to explain.

If you want to also use this on column C then you need to modify the items in red font.

Sub copyDups()
Dim sh As Worksheet, lr As Long
Set sh = ActiveSheet
lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
With sh
    .Range("[COLOR=#B22222]A1:A" [/COLOR]&[COLOR=#B22222][/COLOR] lr).AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 1), True
    For Each c In Cells(lr + 2, 1).CurrentRegion.Offset(1)
        If Application.CountIf(.Range("[COLOR=#B22222]A2:A[/COLOR]" & lr), c.Value) > 1 Then
            Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = c.Value
            .Range("A1:J" & lr).AutoFilter [COLOR=#B22222]1[/COLOR],[COLOR=#B22222] [/COLOR]c.Value
            .Range("A2:J" & lr).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp)(2)
            .AutoFilterMode = False
        End If
    Next
    .Cells(lr + 2, 1).CurrentRegion.ClearContents
End With
End Sub

 

[JLGWhiz]

The filters do not allow blank cells

.

correct typo

 

[gauti]

I don't know what you mean by this. The filters do now allow blank cells. You need to explain.

If you want to also use this on column C then you need to modify the items in red font.

Sub copyDups()
Dim sh As Worksheet, lr As Long
Set sh = ActiveSheet
lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
With sh
    .Range("[COLOR=#B22222]A1:A" [/COLOR]& lr).AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 1), True
    For Each c In Cells(lr + 2, 1).CurrentRegion.Offset(1)
        If Application.CountIf(.Range("[COLOR=#B22222]A2:A[/COLOR]" & lr), c.Value) > 1 Then
            Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = c.Value
            .Range("A1:J" & lr).AutoFilter [COLOR=#B22222]1[/COLOR],c.Value
            .Range("A2:J" & lr).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp)(2)
            .AutoFilterMode = False
        End If
    Next
    .Cells(lr + 2, 1).CurrentRegion.ClearContents
End With
End Sub

ActiveSheet.Name = c.Value at this line since the value of cell is empty/blank its giving me application defined or object defined error...
Also when i run the macro, it is copying the entire column C with the same sheet at the end of all entries..

 

[gauti]

ActiveSheet.Name = c.Value at this line since the value of cell is empty/blank its giving me application defined or object defined error...
Also when i run the macro, it is copying the entire column C with the same sheet at the end of all entries..

I should have explained myself better..i do have cells with no values in the column where we are applying the filter which need to be in a separate sheet by themselves..

 

[JLGWhiz]

There should be no blanks in the range that the c.Value represents. That range is a list of unique values that were filtered out of column A and placed in a special area of the worksheet. However, it could be balking at the ActiveSheet, although the active sheet should be the sheet that was just created in the host workbook. I modified the code to have the name applied specifically to that sheet. See if you still get the error.

Sub copyDups2()
Dim sh As Worksheet, lr As Long
Set sh = ActiveSheet
lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
With sh
    .Range("A1:A" & lr).AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 1), True
    For Each c In Cells(lr + 2, 1).CurrentRegion.Offset(1)
        If Application.CountIf(.Range("A2:A" & lr), c.Value) > 1 Then
            Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
            ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = c.Value
            .Range("A1:J" & lr).AutoFilter 1, c.Value
            .Range("A2:J" & lr).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp)(2)
            .AutoFilterMode = False
        End If
    Next
    .Cells(lr + 2, 1).CurrentRegion.ClearContents
End With
End Sub

Also when i run the macro, it is copying the entire column C with the same sheet at the end of all entries..

I cannot get this behavior in testing.

 

[JLGWhiz]

My apologies, because I was using current region to define the filtered unique values, I overlooked that the filter will consider a blank cell in the range as a unique value(although it should not logically).
Here is a revised code for column C. You need to make a modification to your column A code for the line in red font.

Sub copyDups3()
Dim sh As Worksheet, lr As Long
Set sh = ActiveSheet
lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
With sh
    .Range("C1:C" & lr).AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 1), True
   [COLOR=#b22222] .Range(.Cells(lr + 2, 1), .Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete[/COLOR]
    For Each c In Cells(lr + 2, 1).CurrentRegion.Offset(1)
        If Application.CountIf(.Range("C2:C" & lr), c.Value) > 1 Then
            Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = c.Value
            .Range("A1:J" & lr).AutoFilter 3, c.Value
            .Range("A2:J" & lr).SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Cells(Rows.Count, 1).End(xlUp)(2)
            .AutoFilterMode = False
        End If
    Next
    .Cells(lr + 2, 1).CurrentRegion.ClearContents
End With
End Sub