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.

 

[Euler271]

Just one more thing...I'm not very familiar with scripting dictionaries, though I guess they're something like collections. Do you know how to destroy a dictionary. I've been using your code and it works once. Then I close the workbook and try it again and I get an error message. I'm running it from Access and I have to compact and repair the database before the code works again. I guess that destroys any lingering objects but I'd like to be able to do it at the end of my code. I tried "Set dic = Nothing" but that doesn't seem to work.

 

[Fluff]

Using

Set Dic=Nothing

works for me, but then I'm running from Xl from Access, which maybe the problem.