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

Euler271

New Member
Joined
Dec 4, 2017
Messages
31
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:
VBA Code:
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.
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,609
Office Version
  1. 365
Platform
  1. Windows
Try
VBA Code:
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

New Member
Joined
Dec 4, 2017
Messages
31
Try
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,609
Office Version
  1. 365
Platform
  1. Windows
Oops, it should be
VBA Code:
If R3 Is Nothing Then Set R3 = R2 Else Set R3 = Union(R3, R2)
 

Euler271

New Member
Joined
Dec 4, 2017
Messages
31

ADVERTISEMENT

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:

StateCountry
CAUSA
MNUSA
WIUSA
WIUSA
WAUSA
WAUSA
WAUSA
NYUSA
MAUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
CAX
TXX
TXX
TXX
TXX
TXX
TXX

After the code runs it should look like this:

StateCountry
CAUSA
MNUSA
WIUSA
WIUSA
WAUSA
WAUSA
WAUSA
NYUSA
MAUSA
TXUSA
TXUSA
TXUSA
TXUSA
TXUSA
CAX
TXX
TXX
TXX
TXX
TXX
TXX

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

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,609
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
        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

New Member
Joined
Dec 4, 2017
Messages
31

ADVERTISEMENT

How about
VBA Code:
        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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,609
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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

New Member
Joined
Dec 4, 2017
Messages
31
How about
VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,609
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,659
Messages
5,637,622
Members
416,977
Latest member
kdoederlein

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top