VBA optimising code help...

[zzjasonzz]

Hey,

I have a sheet that looks like:

    A      B              C           D         E        F          G        H           I         
1  ID  UserID  Firstname Surname Type  Score1 Score2 Score3 Score4
2   
3
.
.
.
.
## (could be anything)

There are two types of errors that can occur in the data that i need to find:
- If there is a duplicate UserID (column B) I need to put a 1 in Column M of all rows that are duplicate

- If any of the scores (columns F-I) are greater than 5 or less than 0 then its an error, also sometimes it will have #value in there. In both of these cases i need to put a 1 in column L and clear the particular score that is giving an error.

It works fine, but is really slow (obviously.. its pretty poorly written) for alot of rows. I don't mind doing a mixture of code/formula (i assume the duplicate one can be done by formula).

Sub check_errors()
Dim i
Sheets("Summary of Data").Activate
If Range("A3") = "" Then Exit Sub
If Range("A4") = "" Then Exit Sub
Application.ScreenUpdating = False
Range("M3:M10000").ClearContents
Rows("3:1000").Interior.ColorIndex = 0

For i = 3 To Range("A3").End(xlDown).Row
    Call check_dup(i)
    Call check_error(i)
Next i
Application.ScreenUpdating = True
Range("A3").Select

End Sub

Sub check_error(i)



    Range("L" & i) = ""
    
    If WorksheetFunction.IsError(Range("F" & i)) Then Range("F" & i) = "-1"
    If WorksheetFunction.IsError(Range("G" & i)) Then Range("G" & i) = "-1"
    If WorksheetFunction.IsError(Range("H" & i)) Then Range("H" & i) = "-1"
    If WorksheetFunction.IsError(Range("I" & i)) Then Range("I" & i) = "-1"
    
    If ((Range("F" & i).Value < 0) Or (Range("F" & i).Value > 5)) Then
        Range("F" & i).Formula = ""
        Range("L" & i) = 1
    End If
    
    If ((Range("G" & i).Value < 0) Or (Range("G" & i).Value > 5)) Then
        Range("G" & i).Formula = ""
        Range("L" & i) = 1
    End If
    
    If ((Range("H" & i).Value < 0) Or (Range("H" & i).Value > 5)) Then
        Range("H" & i).Formula = ""
        Range("L" & i) = 1
    End If

    If ((Range("I" & i).Value < 0) Or (Range("I" & i).Value > 5)) Then
        Range("I" & i).Formula = ""
        Range("L" & i) = 1
    End If
End Sub



Sub check_dup(i)
Dim j
Dim checkID

    checkID = Range("B" & i).Value
    Range("B" & i).Select
    For j = 3 To Range("A3").End(xlDown).Row
        'Range("M" & j) = ""
        'Range("M" & i) = ""
        If j <> i Then
            If checkID = Range("B" & j).Value Then
                    Range("M" & j) = 1
                    Range("M" & i) = 1
            End If
        End If
    Next j
End Sub

Thanks for reading!

 

[tusharm]

Yes, using a formula and Advanced Filter (i.e., letting Excel do the heavy lifting) will be extremely fast.

In J2 enter the formula =COUNTIF($A$2:$A$20,A2)>1 where the first reference (A2:A20 in my test) refers to the entire range with data.

In K2 enter the *array* formula =OR(ISERROR(F2:I2))

In L2 enter the *array* formula =OR(F2:I2<0,F2:I2>5)

Now, filter on J being TRUE and delete all visible rows. Next, filter on K being TRUE and delete all visible rows. Finally, filter on L being TRUE and delete all visible rows. Alternatively, use Advanced Filter and find all rows where there is a TRUE in any of the J,K, or L columns and delete all visible rows.

If you must automate the above, turn on the macro recorder while doing the above. You should also check out
Beyond the macro recorder
http://www.tushar-mehta.com/excel/vba/beyond_the_macro_recorder/index.htm

 

[SydneyGeek]

As Tushar said, formulas and filtering will be much quicker.
The code below will write the formulas and convert them to values; you can then deal with the error rows by fitlering.

Sub check_errors_modified()
    Dim i As Long
    Dim Rw As Long
    Dim c As Range
    
    Sheets("Summary of Data").Activate
    If Range("A3") = "" Then Exit Sub
    If Range("A4") = "" Then Exit Sub
    Application.ScreenUpdating = False
    
    'find last row by riding up from bottom of sheet
    Rw = Cells(Rows.Count, 1).End(xlUp).Row
    
    Range("M3:M" & Rows.Count).ClearContents
    Rows("3:1000").Interior.ColorIndex = 0
    
    'convert errors to -1 values
    On Error Resume Next
    Range("F3:I" & Rw).SpecialCells(xlCellTypeFormulas, xlErrors).Value = -1
    On Error GoTo 0
    
    'write error list
    Range("L3").FormulaArray = "=IF(OR(RC[-6]:RC[-3]<0,RC[-6]:RC[-3]>5),1,0)"
    Range("L3").Copy
    Range("L4:L" & Rw).PasteSpecial
    Application.CutCopyMode = False
    
    'write duplicate list
    Range("M3:M" & Rw).FormulaR1C1 = "=IF(COUNTIF(C2,RC2)>1,1,0)"
    
    'convert to values
    Range("L3:M" & Rw).Select
    Selection = Selection.Value
    
    Range("A3").Select
    Application.ScreenUpdating = True
    
End Sub

Denis