Filtering a column for one value then deleting rows based on finding multiple values of another value in a different column

[Euler271]

Hello,

I've been trying to find a way, using VBA, to autofilter for one value in, say, column C of a worksheet then loop through the values in column B looking for values that are duplicated over five times in that column. If that value is duplicated over five times then that row is deleted.

For example, let's say column C shows countries. If I autofilter for "USA" in column C I only want to see a maximum of five instances of any particular state in column B. If there are more than five instances of "CA", for example, then those extra rows are deleted.

Here's the code if have so far:

Sub Test1()
   [COLOR=rgb(26, 188, 156)] 'This works except it leaves a sixth duplicate when the duplicates are bunched together.
    'It will delete the sixth but if the seventh is in the next row, it skips it because the next row now has a different TIN.
    'The seventh duplicate has moved up to the row number just deleted and is now the sixth duplicate since the previous sixth was just deleted.
    'For example, if the sixth is in the 11th row and the seventh in the 12th, it will delete the 11th row which means the seventh (now the sixth) duplicate's 12th row becomes the 11th
    'But the program moves to the 12th row since it just worked on the 11th row thereby missing it.
    'This could be fixed by going through twice but it seems inefficient.
    'I need to be able to loop from the end.[/COLOR]
    Dim N As Long
    Dim R1 As Excel.Range
    Dim R2 As Excel.Range
    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Open("C:\Workbench\Testing\Test.xlsx")
    Set xlWs = xlWb.Sheets("Sheet1")
    xlApp.Visible = True
    N = xlWs.Cells(xlWs.Rows.Count, "A").END(xlUp).row
    Set R1 = xlWs.Range("B2:B" & N)
    xlWb.Sheets("Sheet1").Range("$A$1:$C$" & xlWb.Sheets("Sheet1").Cells(xlWb.Sheets("Sheet1").Rows.Count, "A").END(xlUp).row).AutoFilter Field:=3, Criteria1:="USA", Operator:=xlFilterValues
    For Each R2 In R1.SpecialCells(xlCellTypeVisible)
        If xlApp.WorksheetFunction.CountIf(xlWs.Range("B2:B" & N).SpecialCells(xlCellTypeVisible), xlWs.Range("B" & R2.row).value) > 5 Then xlWs.Range("B" & R2.row).EntireRow.Delete: N = N - 1
    Next R2
    Set xlWs = Nothing
    Set xlWb = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    MsgBox "Done!"
End Sub

I need to be able to loop through the visible rows from the end so I need to "For...Next" loop instead of "For Each...Next" loop unless there's a way to step backwards through a "For Each...Loop" but I haven't found it.

Thanks for any help with this.

 

[Fluff]

Try

Sub Test1()
    Dim N As Long
    Dim R1 As Excel.Range
    Dim R2 As Excel.Range
    Dim R3 As Excel.Range
    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Open("C:\Workbench\Testing\Test.xlsx")
    Set xlWs = xlWb.Sheets("Sheet1")
    xlApp.Visible = True
    N = xlWs.Cells(xlWs.Rows.Count, "A").End(xlUp).Row
    Set R1 = xlWs.Range("B2:B" & N)
    xlWb.Sheets("Sheet1").Range("$A$1:$C$" & xlWb.Sheets("Sheet1").Cells(xlWb.Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=3, Criteria1:="USA", Operator:=xlFilterValues
    For Each R2 In R1.SpecialCells(xlCellTypeVisible)
        If xlApp.WorksheetFunction.CountIf(xlWs.Range("B2:B" & N).SpecialCells(xlCellTypeVisible), xlWs.Range("B" & R2.Row).Value) > 5 Then
            If R3 Is Nothing Then R3 = R2 Else Set R3 = Union(R3, R2)
        End If
    Next R2
    If Not R3 Is Nothing Then R3.EntireRow.Delete
    Set xlWs = Nothing
    Set xlWb = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    MsgBox "Done!"
End Sub

 

[Euler271]

Try

Sub Test1()
    Dim N As Long
    Dim R1 As Excel.Range
    Dim R2 As Excel.Range
    Dim R3 As Excel.Range
    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Open("C:\Workbench\Testing\Test.xlsx")
    Set xlWs = xlWb.Sheets("Sheet1")
    xlApp.Visible = True
    N = xlWs.Cells(xlWs.Rows.Count, "A").End(xlUp).Row
    Set R1 = xlWs.Range("B2:B" & N)
    xlWb.Sheets("Sheet1").Range("$A$1:$C$" & xlWb.Sheets("Sheet1").Cells(xlWb.Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=3, Criteria1:="USA", Operator:=xlFilterValues
    For Each R2 In R1.SpecialCells(xlCellTypeVisible)
        If xlApp.WorksheetFunction.CountIf(xlWs.Range("B2:B" & N).SpecialCells(xlCellTypeVisible), xlWs.Range("B" & R2.Row).Value) > 5 Then
            If R3 Is Nothing Then R3 = R2 Else Set R3 = Union(R3, R2)
        End If
    Next R2
    If Not R3 Is Nothing Then R3.EntireRow.Delete
    Set xlWs = Nothing
    Set xlWb = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    MsgBox "Done!"
End Sub

Thanks for the suggestion but I'm getting a RT error #91: "Object variable or With block variable not set".

 

[Fluff]

Oops, it should be

If R3 Is Nothing Then Set R3 = R2 Else Set R3 = Union(R3, R2)

 

[Euler271]

Thanks for the correction. I'm not getting the error message now but there's another problem.

After filtering, the object is to leave five rows with the same state and delete any other rows with the same state. So if the worksheet shows 12 rows for "TX", after the code runs five rows with "TX" should remain. Your code deletes all of the rows showing "TX". Here's an example:

State	Country
CA	USA
MN	USA
WI	USA
WI	USA
WA	USA
WA	USA
WA	USA
NY	USA
MA	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
CA	X
TX	X
TX	X
TX	X
TX	X
TX	X
TX	X

After the code runs it should look like this:

State	Country
CA	USA
MN	USA
WI	USA
WI	USA
WA	USA
WA	USA
WA	USA
NY	USA
MA	USA
TX	USA
TX	USA
TX	USA
TX	USA
TX	USA
CA	X
TX	X
TX	X
TX	X
TX	X
TX	X
TX	X

Thanks for your efforts, anyway. I'll keep plugging away.

 

[Fluff]

How about

        If Application.WorksheetFunction.CountIf(xlws.Range("B1:B" & R2.Row).SpecialCells(xlCellTypeVisible), xlws.Range("B" & R2.Row).Value) > 5 Then
            If R3 Is Nothing Then Set R3 = R2 Else Set R3 = Union(R3, R2)
        End If

 

[Euler271]

How about

        If Application.WorksheetFunction.CountIf(xlws.Range("B1:B" & R2.Row).SpecialCells(xlCellTypeVisible), xlws.Range("B" & R2.Row).Value) > 5 Then
            If R3 Is Nothing Then Set R3 = R2 Else Set R3 = Union(R3, R2)
        End If

I tried it on a short list of values and it worked. I then tried it on the complete list (2386 rows + header) and I got RT error 1004: "Unable to get the CountIf property of the WorksheetFunction class". I then tried it on a list of values without filtering or using the visible cells property and it worked.

I might have to filter, copy the filtered results to a new worksheet then run the code if I can't get the CountIf function to work using filtering on a large number of rows.

 

[Fluff]

How about

Sub Test1()
   Dim N As Long
   Dim R1 As Excel.Range
   Dim R2 As Excel.Range
   Dim R3 As Excel.Range
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   Set xlWb = Workbooks.Open("C:\Workbench\Testing\Test.xlsx")
   Set xlws = xlWb.Sheets("Sheet1")
   N = xlws.Cells(xlws.Rows.Count, "A").End(xlUp).Row
   Set R1 = xlws.Range("B2:B" & N)
   xlws.Range("$A$1:$C$" & N).AutoFilter Field:=3, Criteria1:="USA"
   For Each R2 In R1.SpecialCells(xlCellTypeVisible)
      Dic(R2.Value) = Dic(R2.Value) + 1
      If Dic(R2.Value) > 5 Then
         If R3 Is Nothing Then Set R3 = R2 Else Set R3 = Union(R3, R2)
      End If
   Next R2
   If Not R3 Is Nothing Then R3.EntireRow.Delete
   Set xlws = Nothing
   xlWb.Close True
   Set xlWb = Nothing
   MsgBox "Done!"
End Sub

 

[Euler271]

How about

Sub Test1()
   Dim N As Long
   Dim R1 As Excel.Range
   Dim R2 As Excel.Range
   Dim R3 As Excel.Range
   Dim Dic As Object
  
   Set Dic = CreateObject("scripting.dictionary")
   Set xlWb = Workbooks.Open("C:\Workbench\Testing\Test.xlsx")
   Set xlws = xlWb.Sheets("Sheet1")
   N = xlws.Cells(xlws.Rows.Count, "A").End(xlUp).Row
   Set R1 = xlws.Range("B2:B" & N)
   xlws.Range("$A$1:$C$" & N).AutoFilter Field:=3, Criteria1:="USA"
   For Each R2 In R1.SpecialCells(xlCellTypeVisible)
      Dic(R2.Value) = Dic(R2.Value) + 1
      If Dic(R2.Value) > 5 Then
         If R3 Is Nothing Then Set R3 = R2 Else Set R3 = Union(R3, R2)
      End If
   Next R2
   If Not R3 Is Nothing Then R3.EntireRow.Delete
   Set xlws = Nothing
   xlWb.Close True
   Set xlWb = Nothing
   MsgBox "Done!"
End Sub

Perfect! I don't know how it works but it does. Thanks a million for your help with this.

 

[Fluff]

You're welcome & thanks for the feedback.