Option Compare Database
Option Explicit
Dim varArray() As Variant, i As Long
Public Function QrySeq(ByVal fldvalue, _
ByVal fldName As String, _
ByVal QryName As String, _
ByVal ctrlField As String) As Long
'-------------------------------------------------------------------------------
'Purpose: Create Sequence Numbers in Query in a new Column
'Author : a.p.r. pillai
'Date : Dec. 2009
'URL : www.msaccesstips.com
'All Rights Reserved by www.msaccesstips.com
'-------------------------------------------------------------------------------
'Parameter values
'-------------------------------------------------------------------------------
'1 : Column Value - must be unique Values from the Query
'2 : Column Name - the Field Name from Unique Value Taken
'3 : Query Name - Name of the Query this Function is Called from
'4 : Group Column Name - To check & Reset the Serial to Zero
'-------------------------------------------------------------------------------
'Limitations - Function must be called with a Unique Field Value like AutoNumber
' - as First Parameter
' - Need to Save the Query after change before opening
' - in normal View.
'-------------------------------------------------------------------------------
Dim k As Long
On Error GoTo QrySeq_Err
restart:
If i = 0 Or DCount("*", QryName) <> i Then
Dim j As Long, db As Database, rst As Recordset
i = DCount("*", QryName)
ReDim varArray(1 To i, 1 To 4) As Variant
Set db = CurrentDb
Set rst = db.OpenRecordset(QryName, dbOpenDynaset)
j = 1: k = 1
Do While j <= i And Not rst.EOF
varArray(j, 1) = rst.Fields(fldName).Value
varArray(j, 2) = k - 1
varArray(j, 3) = fldName
If j <> 1 And j <> i Then
If rst.Fields(ctrlField).Value <> varArray(j - 1, 4) Then
varArray(j, 2) = 0
k = 1
varArray(j, 4) = rst.Fields(ctrlField).Value
Else
varArray(j, 4) = rst.Fields(ctrlField).Value
End If
Else
varArray(j, 4) = rst.Fields(ctrlField).Value
End If
rst.MoveNext
j = j + 1: k = k + 1
Loop
rst.Close
End If
If varArray(1, 3) & varArray(1, 1) <> (fldName & DLookup(fldName, QryName)) Then
i = 0
GoTo restart
End If
For k = 1 To i
If varArray(k, 1) = fldvalue Then
QrySeq = varArray(k, 2)
Exit Function
End If
Next
QrySeq_Exit:
Exit Function
QrySeq_Err:
MsgBox Err & " : " & Err.Description, , "QrySeqQ"
Resume QrySeq_Exit
End Function