i ripped this code from my other sub, but it works by you
creating a query to sort the data in the order to be ranked. Cata, DAte.
here its called "qsSortData"
then assign these variables in the code.
pvQry = "qsSortData"
pvFld2Check = "Catagory"
pvChgFld = "Rank"
then run: RankAllRecs
Code:
Public Sub RankAllRecs()
'pvQry = query name
'pvChgFld = field to change when duplicate is found
Dim vMsg
Dim db As Database
Dim rst 'As Recordset
Dim qdf As QueryDef
Dim vCurrDup, vPrevDup, vKey, vCurrFld, vAddr, vPrevFld
Dim pvQry, pvFld2Check, pvChgFld
Dim i As Integer
On Error GoTo ErrRemove
'DoCmd.Hourglass True
'set params
pvQry = "qsSortData"
pvFld2Check = "Catagory"
pvChgFld = "Rank"
Set db = currentdb
Set qdf = db.QueryDefs(pvQry)
Set rst = qdf.openRecordset(dbOpenDynaset)
vPrevFld = "*&%"
With rst
While Not .EOF
vCurrFld = .Fields(pvFld2Check).Value & ""
If vPrevFld = "*&%" Then vPrevFld = vCurrFld
'-----------------------
'MARK the like values
'-----------------------
If vPrevFld = vCurrFld Then 'mark this
i = i + 1
GoSub UpdFld
Else
i = 1
GoSub UpdFld
End If
vPrevFld = vCurrFld
.MoveNext
Wend
UpdFld:
.Edit
.Fields(pvChgFld) = i
.Update
Return
End With
endit:
Set qdf = Nothing
Set rst = Nothing
Set db = Nothing
DoCmd.OpenQuery pvQry
'MsgBox "Done", , "Remove Dupes"
Exit Sub
ErrRemove:
If Err = 3021 Then GoTo endit
MsgBox Err.Description, , "rank():" & Err
Resume endit
Resume
End Sub