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.

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