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)
                    With Range("A1")
                        .AutoFilter Field:=3, Criteria1:="<4"
                            Lastmm = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
                            Range("A2:C" & Lastmm).Select
                            Range("A" & lrdata).PasteSpecial Paste:=xlPasteValues
                            Application.CutCopyMode = False
                            lrdata = Sheets("data").Cells(Rows.Count, "A").End(xlUp).Row + 1
                            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
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()

'ActiveWorkbook.Sheets.Add.Name = "temp"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "temp"

' remove duplicates
With ActiveWorkbook.ActiveSheet
    .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"
    currentCell = 2
End If


End Sub

Example of spreadsheet data before the process.

View example of spreadsheet data


1 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
        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
            End With
        Application.ScreenUpdating = True
    End If
End Sub
  • 2
    \$\begingroup\$ You are honest. \$\endgroup\$ Commented Sep 15, 2017 at 7:38
  • 2
    \$\begingroup\$ Plagiarism is bad. \$\endgroup\$
    – Tim G
    Commented Sep 15, 2017 at 16:27
  • \$\begingroup\$ 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... \$\endgroup\$ Commented Sep 16, 2017 at 5:28
  • \$\begingroup\$ I filter row a for every unique item Then filter row c for every unique item from row a. \$\endgroup\$
    – Tim G
    Commented Sep 17, 2017 at 5:27

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.