Make code faster/better best practices

**welchs101** · 12-28-2008, 07:14 AM

Thanks SHG. I am still reviewing the code you sent. My skill level not quite the same as yours but i am good enough to review it and learn some things. So thanks.

**shg** · 12-28-2008, 02:29 PM

A couple of changes to ignore case in name comparisons, and to avoid an error if the number of adds or drops is zero:

Sub AddRem(rCur As Range, rOld As Range, rAdd As Range, rDrp As Range)
    Dim nCur    As Long     ' current students
    Dim nOld    As Long     ' prior students

    Dim asAdd() As String   ' array of new
    Dim asDrp() As String   ' array of drops

    Dim iCur    As Long     ' index to current students
    Dim iOld    As Long     ' index to prior students

    Dim nAdd    As Long     ' number of new students
    Dim nDrp    As Long     ' number of drops

    nCur = rCur.Count
    nOld = rOld.Count

    ReDim asAdd(1 To nCur)    ' max  adds is everyone here this year
    ReDim asDrp(1 To nOld)    ' max drops is everyone here last year
    
    ' clear output area
    rAdd.Resize(nCur).ClearContents
    rDrp.Resize(nOld).ClearContents
    
    ' sort both lists
    rCur.Sort Key1:=rCur(1), Order1:=xlAscending, MatchCase:=False, Header:=xlNo
    rOld.Sort Key1:=rOld(1), Order1:=xlAscending, MatchCase:=False, Header:=xlNo

    iCur = 1
    iOld = 1
    Do
        Select Case StrComp(rCur(iCur).Text, rOld(iOld).Text, vbTextCompare)
            Case -1    ' cur < old; current is new
                'rCur(iCur).Select   ' debug
                nAdd = nAdd + 1
                asAdd(nAdd) = rCur(iCur).Text
                iCur = iCur + 1
            
            Case 0  ' cur = old; continuing student
                iCur = iCur + 1
                iOld = iOld + 1
            
            Case 1  ' old < cur; old is a drop
                'rOld(iOld).Select   ' debug
                nDrp = nDrp + 1
                asDrp(nDrp) = rOld(iOld).Text
                iOld = iOld + 1
        End Select
        If iCur > nCur Or iOld > nOld Then Exit Do
    Loop

    ' add any remaining current students to add list
    For iCur = iCur To nCur
        nAdd = nAdd + 1
        asAdd(nAdd) = rCur(iCur).Text
    Next iCur

    ' add any remaining old students to drop list
    For iOld = iOld To nOld
        nDrp = nDrp + 1
        asDrp(nDrp) = rOld(iOld).Text
    Next iOld

    ' output each list if not empty
    If nAdd > 0 Then
        ReDim Preserve asAdd(1 To nAdd)
        rAdd.Resize(nAdd).Value = WorksheetFunction.Transpose(asAdd)
    End If
    
    If nDrp > 0 Then
        ReDim Preserve asDrp(1 To nDrp)
        rDrp.Resize(nDrp).Value = WorksheetFunction.Transpose(asDrp)
    End If
End Sub

**welchs101** · 12-29-2008, 07:19 AM

Hi SHG,

I think i found an error in the code.

Recall the following section of code:

If iCur >= nCur Or iOld > nOld Then Exit Do

I think this should actually be the following (no equal sign)

If iCur > nCur Or iOld > nOld Then Exit Do

I have not checked your latest code but i think it still has this issue. I will check your new code now. also, i modified it slightly so that the inputs to the procedure are the same as my old one.

**welchs101** · 12-29-2008, 08:32 AM

Hi Shg,

In reviewing your code more closely i realized that the "sort" was very important. Without it the procedure would not work correctly. If i sort the ranges as is then data would not align correctly as beside the names are grades and if sort just the names then the grades would not line-up with the right names.

I really like your code though. Its very compact and i learned something from it.

the procedure i currently use has the following inputs:

Sub compare_lists(droparray() As String, addarray() As String, Currentlist As Range, Newlist As Range)

so this is what i am working with. i cant use your code unless i sort all rows in the given range. what i wonder is if i should read each range into an array and compare just the arrays? suggestions.

**welchs101** · 12-29-2008, 01:01 PM

hi Shg, below is the code i came up with based on your helpful inputs. I learned alot.

Sub compare_lists(droparray() As String, addarray() As String, Currentlist As Range, Newlist As Range)

Dim x As Long
Dim mtch As Boolean
Dim array_cntr As Long
Dim cntr As Long


'droparray
array_cntr = 1
For x = 1 To Currentlist.Count
    cntr = 1
    mtch = False
    Do
        If Currentlist.Cells(x, 1) = Newlist.Cells(cntr, 1) Then
            mtch = True
        Else: cntr = cntr + 1
        End If
        If mtch Or (cntr > Newlist.Count) Then Exit Do
    Loop
    If Not mtch Then
    ReDim Preserve droparray(array_cntr)
    droparray(array_cntr) = Currentlist.Cells(x, 1)
    array_cntr = array_cntr + 1
    End If
Next x

'addarray
array_cntr = 1
For x = 1 To Newlist.Count
    cntr = 1
    mtch = False
    Do
        If Newlist.Cells(x, 1) = Currentlist.Cells(cntr, 1) Then
            mtch = True
        Else: cntr = cntr + 1
        End If
        If mtch Or (cntr > Currentlist.Count) Then Exit Do
    Loop
    If Not mtch Then
    ReDim Preserve addarray(array_cntr)
    addarray(array_cntr) = Newlist.Cells(x, 1)
    array_cntr = array_cntr + 1
    End If
Next x

'for debug
'For x = 1 To UBound(droparray())
'Workbooks("working_file.xlsm").Worksheets("compare_test").Range("j" & x + 1) = droparray(x)
'Next x

'for debug
'For x = 1 To UBound(addarray())
'Workbooks("working_file.xlsm").Worksheets("compare_test").Range("k" & x + 1) = addarray(x)
'Next x


End Sub

**shg** · 12-29-2008, 02:17 PM

You should compare performance of the two approaches with perhaps 25,000 names.

Redim Preserve is an expensive operation; that's why I resized the arrays to their max possible size at the outset.