Find identical data in 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()

' copy and move the data from the data sheet, column A (can be changed if needed) to a new sheet called "temp"


' 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
'MsgBox (currentCell)

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
'                Range("A1" & .Cells(Rows.Count, 1).End(xlUp).Row).Select
                    With Range("A1")
'                        .AutoFilter
                        .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
                'Range("A1" & .Cells(Rows.Count, 1).End(xlUp).Row).Select
                'With Selection
'                lr = Sheets("mm").Cells(Rows.Count, "A").End(xlUp).Row + 1
                End If
            currentCell = currentCell + 1
        '    MsgBox (currentCell)
        '    MsgBox (numOfValues)
'            .AutoFilter
        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
'    MsgBox (numOfValues)
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

'MsgBox (currentCell)

Sheet1.Activate
Sheet1.Range("A1").Select
Selection.AutoFilter

End Sub

Example spreadsheet looks like this

Answer 1

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

1. Filter col A
2. 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

---

Sheet1 and Sheet2

---

Edit:

There are 3 ways to refer to sheets:

• Sheet Name (or Tab Name) - The name visible by user in the tab (lower-left)
• Sheet Index (or Tab Index) - The order of the tab as it appears to the user (lower-left)
• CodeName - this is the name of the sheet only visible in the VBA editor (top-left)

In the code bellow we are referring to the same sheet:

Public Sub SheetNames()
    Dim ws2 As Worksheet

    ws2 = Sheets("Sheet2")    'Tab Name
    ws2 = Sheets(2)           'Tab Index
    ws2 = Sheet2              'CodeName (visible only in the VBA editor)
End Sub

---

References to the sheet:

The CodeName is more reliable in VBA because normal users will not edit it (unlikely to change)

Another distinction to be made is between the Sheets() collection and the Worksheets() collection:

The Sheets collection consist of not only a collection of worksheets but also other types of sheets to include Chart sheets (...)

( more details from Microsoft )