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

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.

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

Worksheets("temp").Delete

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

' remove duplicates
Worksheets("temp").Range("A1").Select
With ActiveWorkbook.ActiveSheet
.Paste
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. 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

• You are honest. Sep 15, 2017 at 7:38
• Plagiarism is bad. Sep 15, 2017 at 16:27
• 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... Sep 16, 2017 at 5:28
• I filter row a for every unique item Then filter row c for every unique item from row a. Sep 17, 2017 at 5:27