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.
