Sorting data by duplicates

[Mike2502]

Hi All,

I have a piece of code which I have put below, I need to try and somehow alter it slightly.

The code below sorts the data by seeing whether a cell color in Column A is 255, 0, 0 and then it will copy and paste it onto sheet "ToDo" and then delete it on the original spreadsheet... however I want to change it where if there is;

2 Duplicates = Gets copied onto spreadsheet "ToDo_2"​

3 Duplicates = Gets copied onto spreadsheet "ToDo_3"​

4 Duplicates = Gets copied onto spreadsheet "ToDo_4"​

​

I hope this makes sense and thanks in advance

Sub Sort_Data()
  
            With Sheets("Sort")

         If .AutoFilterMode Then .AutoFilterMode = False
              With .Range("A1:O50" & .Range("A" & Rows.Count).End(xlUp).Row)
                  .AutoFilter 1, RGB(255, 0, 0), xlFilterCellColor
                  .Offset(1).Copy Sheets("ToDo").Range("A" & Rows.Count).End(xlUp)(2)
                  .Offset(1).Delete
                  Sheets("Sort").ShowAllData
          End With
         
   Range("A2").Select   
End Sub

 

[Peter_SSs]

Try this with a copy of your workbook.
I have assumed that sheet "ToDo" could be (or already has been) named 'ToDo_1' and that any required 'ToDo_n' already exist.

Sub Sort_Data()
  With Sheets("Sort")
    If .AutoFilterMode Then .AutoFilterMode = False
    With .Range("A1:O" & .Range("A" & Rows.Count).End(xlUp).Row)
      .AutoFilter 1, RGB(255, 0, 0), xlFilterCellColor
      If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
        .Offset(1).Copy Sheets("ToDo_" & .Columns(1).SpecialCells(xlVisible).Count - 1).Range("A" & Rows.Count).End(xlUp)(2)
        .Offset(1).EntireRow.Delete
      End If
      Sheets("Sort").ShowAllData
    End With
    .Range("A2").Select
  End With
End Sub

 

[Mike2502]

Try this with a copy of your workbook.
I have assumed that sheet "ToDo" could be (or already has been) named 'ToDo_1' and that any required 'ToDo_n' already exist.

Sub Sort_Data()
  With Sheets("Sort")
    If .AutoFilterMode Then .AutoFilterMode = False
    With .Range("A1:O" & .Range("A" & Rows.Count).End(xlUp).Row)
      .AutoFilter 1, RGB(255, 0, 0), xlFilterCellColor
      If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
        .Offset(1).Copy Sheets("ToDo_" & .Columns(1).SpecialCells(xlVisible).Count - 1).Range("A" & Rows.Count).End(xlUp)(2)
        .Offset(1).EntireRow.Delete
      End If
      Sheets("Sort").ShowAllData
    End With
    .Range("A2").Select
  End With
End Sub

Hi Peter,

Thanks for your help!

I get what you've done however I get an error 'Subscript out of range' for Line

And you are correct the ToDo_N sheets are already created

With Sheets("Sort")
    If .AutoFilterMode Then .AutoFilterMode = False
     With .Range("A1:O50" & .Range("B" & Rows.Count).End(xlUp).Row)
            .AutoFilter 2, RGB(255, 0, 0), xlFilterCellColor
            .Offset(1).Copy Sheets("Dis").Range("A" & Rows.Count).End(xlUp)(2)
            .Offset(1).Delete
    End With
   
    With .Range("A1:O50" & .Range("A" & Rows.Count).End(xlUp).Row)
      .AutoFilter 1, RGB(255, 0, 0), xlFilterCellColor
      If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
'error on below line

        .Offset(1).Copy Sheets("ToDo_" & .Columns(1).SpecialCells(xlVisible).Count - 1).Range("A" & Rows.Count).End(xlUp)(2)
        .Offset(1).EntireRow.Delete
      End If
      Sheets("Sort").ShowAllData
    End With
    .Range("A2").Select
  End With

 

[Mike2502]

bump

 

[Peter_SSs]

bump

Be patient - your previous message was posted at 11:32 pm my time so I'm afraid I was asleep.

'error on below line

.Offset(1).Copy Sheets("ToDo_" & .Columns(1).SpecialCells(xlVisible).Count - 1).Range("A" & Rows.Count).End(xlUp)(2)

The error noted on that line indicates that a "ToDo_n' sheet with the correct value in place of n does not exist in the workbook.

When you get that error, how many red rows, not counting the header row, are visible in the AutoFilter range? If the answer is 5 then a sheet called 'ToDo_5' must already exist

 

[Mike2502]

Be patient - your previous message was posted at 11:32 pm my time so I'm afraid I was asleep.


The error noted on that line indicates that a "ToDo_n' sheet with the correct value in place of n does not exist in the workbook.

When you get that error, how many red rows, not counting the header row, are visible in the AutoFilter range? If the answer is 5 then a sheet called 'ToDo_5' must already exist

Sorry! Needed this before Monday aha

But I think I didn't explain it properly so let's say there's 2 duplicates of abc123 they need to go on sheet "ToDo_2"

And then there's 3 duplicates of Xyz456 they need to go on sheet "ToDo_3"

There won't be more than 4 duplicates, I hope this makes sense

 

[Peter_SSs]

so let's say there's 2 duplicates of abc123 they need to go on sheet "ToDo_2"

In this exercise, we are first filtering for red. Is it possible that after the red filter there could be 2 red duplicates of 'abc123' but also 1 or more non-red 'abc123' values hidden in column A because of the red filter? That is, could we have the data below where rows 3 & 6 should go to the 'ToDo_2' sheet but row 12 goes nowhere?

Mike2502 2020-03-01 1.xlsm
	A
1	Data
2	A2
3	abc123
4	A5
5	Xyz456
6	abc123
7	A8
8	A9
9	Xyz456
10	Xyz456
11	A14
12	abc123
13	A16
Sort

 

[Mike2502]

Hi Peter

So all the duplicates are highlighted red in column A, so row 12 would also be red and because Abc123 has come up 3 times I want these rows to go to 'ToDo_3' and same with Xyz456.. But I've just thought about it I don't think it's possible to do but let me know if I'm wrong haha

 

[Peter_SSs]

Thanks for the additional information. Give this a try with a copy of your workbook.

Sub Sort_Data_v2()
  Dim d As Object, itm As Variant
  Dim c As Range
  
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sort")
    If .AutoFilterMode Then .AutoFilterMode = False
    With .Range("A1:O" & .Range("A" & Rows.Count).End(xlUp).Row)
      .AutoFilter Field:=1, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
      If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
        For Each c In .Columns(1).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
          d(c.Value) = d(c.Value) + 1
        Next c
        For Each itm In d.Keys
          .AutoFilter Field:=1, Criteria1:=itm
          .Offset(1).Copy Sheets("ToDo_" & d(itm)).Range("A" & Rows.Count).End(xlUp)(2)
          .Offset(1).EntireRow.Delete
        Next itm
      End If
    End With
    .ShowAllData
    .Range("A2").Select
  End With
End Sub

 

[Mike2502]

Thanks for the additional information. Give this a try with a copy of your workbook.

Sub Sort_Data_v2()
  Dim d As Object, itm As Variant
  Dim c As Range
 
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sort")
    If .AutoFilterMode Then .AutoFilterMode = False
    With .Range("A1:O" & .Range("A" & Rows.Count).End(xlUp).Row)
      .AutoFilter Field:=1, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
      If .Columns(1).SpecialCells(xlVisible).Count > 1 Then
        For Each c In .Columns(1).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
          d(c.Value) = d(c.Value) + 1
        Next c
        For Each itm In d.Keys
          .AutoFilter Field:=1, Criteria1:=itm
          .Offset(1).Copy Sheets("ToDo_" & d(itm)).Range("A" & Rows.Count).End(xlUp)(2)
          .Offset(1).EntireRow.Delete
        Next itm
      End If
    End With
    .ShowAllData
    .Range("A2").Select
  End With
End Sub

Thanks Peter thats brilliant, perfect mate. Only issue is when it sorts the data and I'm back to the original sheet "Sort" all the data is hidden? Any way to unhide this?

Cheers again