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.