Find all identical data in a Column and filter it to another sheet

Question

I have spent hours on this code, and truthfully need some better expert opinion.

Column A on Sheet 1 has dynamic list of data, typically IP address, but for this it is simply a number. There can be duplicates or not.

I need to find all identical data in column A, select it, and run specific code for it, then run the same code for each sets of identical data in A. My code is to find values in column C that matches the criteria of Less Than 4, or <4. Column C will only have values from 1 to 5. Goal is for each set of identical data in A, to then look at C and select any value in C that is only 1, 2, or 3, and NOT 4 or 5, and copy the entire row to another sheet when that is true.

My code works, kinda, but is slow, and does not account for if there is no data to copy.

Right now I use a sheet called Test to find unique data from A, then copy the identical data in A to a sheet called mm, filter the data, then copy only the filtered data to the sheet data. Contents in M are deleted on each loop and Test is deleted at the end of the code.

Please help me clean this up and make it faster. An image link is below if you want to see example data.

Credit goes to christodorov for getting me started as I used his base code.

Dim currentCell As Long
Dim numOfValues As Long
Sub filterNextResult()
' check to make sure there is at least 1 data point in column A on the temp sheet
If currentCell = 0 Then
Application.ScreenUpdating = False
Call createNewTemp
Application.ScreenUpdating = True
End If
' find the total number of unique data points we will be filtering by in column A of the temp sheet
If numOfAccounts = 0 Then
Application.ScreenUpdating = False
Call findNumOfValues
Application.ScreenUpdating = True
End If
Dim X As Integer
Dim lr As Long
Dim lrdata As Long
Dim Lastmm As Integer
lr = Sheets("mm").Cells(Rows.Count, "A").End(xlUp).Row + 1
lrdata = Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row + 1
currentCell = 2
numOfValues = 21
On Error Resume Next
For X = 1 To numOfValues
 With Sheet1.UsedRange
 .AutoFilter 1, Worksheets("temp").Range("A" & currentCell).Value
 Set filRange = .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
 If Not IsEmpty(filRange) Then
 filRange.EntireRow.Copy Destination:=Sheets("mm").Range("A" & lr)
 Worksheets("mm").Activate
 Range("A1").Select
 With Range("A1")
 .AutoFilter Field:=3, Criteria1:="<4"
 Lastmm = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
 Range("A2:C" & Lastmm).Select
 Selection.Copy
 Worksheets("data").Activate
 Range("A" & lrdata).PasteSpecial Paste:=xlPasteValues
 Application.CutCopyMode = False
 lrdata = Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row + 1
 Worksheets("mm").Activate
 Range("A1").Select
 Worksheets("mm").AutoFilterMode = False
 Lastmm = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
 Range("A2:C" & Lastmm).Select
 Selection.Delete shift:=xlToLeft
 End With
 End If
 currentCell = currentCell + 1
 End With
Next X
Application.DisplayAlerts = False
Worksheets("temp").Delete
Application.DisplayAlerts = True
End Sub
'sub that will look for the number of values on the temp sheet column a
Private Sub findNumOfValues()
' count the number of non empty cells and assign that value (less 1 for the title in our case) to the numOfValues
numOfValues = Worksheets("temp").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
End Sub
Private Sub createNewTemp()
Sheet1.Range("A:C").Copy
'ActiveWorkbook.Sheets.Add.Name = "temp"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "temp"
' remove duplicates
Worksheets("temp").Range("A1").Select
With ActiveWorkbook.ActiveSheet
 .Paste
 .Range("A:C").RemoveDuplicates Columns:=Array(1), Header:=xlYes
End With
' check to make sure there are vlaues in the temp sheet
If Worksheets("temp").Range("A2").Value = "" Then
 MsgBox "There are no filter values"
 End
Else
 currentCell = 2
End If
Sheet1.Activate
Sheet1.Range("A1").Select
Selection.AutoFilter
End Sub

Example of spreadsheet data before the process.

View example of spreadsheet data

Answer 1

Credit to paul bica as he helped me. His code is below.

This will iterate through each unique value in column A, Sheet1 with these steps

Filter col A Apply the second filter to column C (< 4) If any rows are visible copies them to the first empty cell in Col A of Sheet2

Option Explicit
Public Sub FindIdenticalInALessThan4InC()
 Const COL_A = 1
 Const COL_C = 3
 Const LESS_THAN_4 = "<4"
 Dim ws1 As Worksheet, ws2 As Worksheet, lrWs1 As Long, lrWs2 As Long
 Dim arrA As Variant, d As Object, i As Long, unique As Variant, maxRows As Long
 Set ws1 = Sheet1: Set ws2 = Sheet2 'ws2 = CodeName for Sheets("mm")
 maxRows = Rows.Count
 If ws1.AutoFilterMode Then ws1.UsedRange.AutoFilter 'clear filters
 lrWs1 = ws1.Cells(maxRows, "A").End(xlUp).Row + 1
 lrWs2 = ws2.Cells(maxRows, "A").End(xlUp).Row + 1
 If lrWs1 > 1 Then 'expects first row as headers
 Set d = CreateObject("Scripting.Dictionary")
 arrA = ws1.Range(ws1.Cells(1, COL_A), ws1.Cells(lrWs1, COL_A))
 For i = 2 To lrWs1
 d(arrA(i, 1)) = vbNullString 'get uniques from col A
 Next
 Application.ScreenUpdating = False
 For Each unique In d
 With ws1.UsedRange
 .AutoFilter Field:=COL_A, Criteria1:=unique
 .AutoFilter Field:=COL_C, Criteria1:=LESS_THAN_4, Operator:=xlAnd
 If .Columns(1).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
 .Offset(1).Resize(lrWs1 - 2, .Columns.Count).Copy ws2.Cells(lrWs2, "A")
 lrWs2 = ws2.Cells(maxRows, "A").End(xlUp).Row + 1
 End If
 .AutoFilter
 End With
 Next
 Application.ScreenUpdating = True
 End If
End Sub

• Billal BEGUERADJ: You are honest.
• Tim G: Plagiarism is bad.
• Dirk Reichel: I really don't get it. You filter the list for every item in column A. But, why? Looking at your data, you would get row 1 and then row 6 and row 7 and.... But just applying the filter to column C will provide exactly the same list. That way you could copy paste the whole data in one step. I can't see what you are doing with the filtered data except from copying it...
• Tim G: I filter row a for every unique item Then filter row c for every unique item from row a.