Count and insert unique values - Can this code be

问题:

I needed to generate an output from my Access database that was unavailable using standard functions. I did extensive searching, but when I found example code - it ultimately failed. So, I started from scratch, pulling from others' work where possible. The code below is probably very primitive, but it works for me and the operation in the database. What I'd really like to see is how this code could be made more compact and efficient. I'm not dealing with many lines today (<20), but I could in the future.

The data:

• a
• b
• b
• b
• c
• c
• d

The desired result:

• a, 1
• b, 2
• b, 2
• b, 2
• c, 3
• c, 3
• d, 4

Can anyone help refine/optimize this code? Please insert comments so I understand what is happening at each step.

Option Compare Database

Public Function QrySeqCPM(ByVal fldvalue, ByVal fldName As String, ByVal QryName As String)
  'Set up the function in the query like this: QrySeqCPM([field name], "field name","query name")
  Dim x, a As Integer, i As Integer, s As Integer, k As Integer, m As Integer, n As Integer, p As Integer, db As Database, rst As Recordset, J As Integer, IndexArray As Variant, MatchFound As String, ReferenceArray As Variant, UB As Integer, CurrVal As Variant
  a = 0
  i = 0
  s = 1
  J = 1
  k = 0
  m = 1
  n = 1
  p = 1
  x = 0
  MatchFound = "False"
  ReDim ReferenceArray(1, 1 To 4) As Variant
  ReferenceArray(1, 1) = "dummy"                      'These 4 entries prime the Array with a dummy result to that the first check doesn't error
  ReferenceArray(1, 2) = 1
  ReferenceArray(1, 3) = 1
  ReferenceArray(1, 4) = 1                            'This result will always be "1" as it is the first result

  i = DCount("*", QryName)                            'Counts the qty of rows in the resultant query.  This "i" value stays constant throughout the script.
  ReDim IndexArray(1 To i, 1 To 4) As Variant         'Required to enable the Erase IndexArray later, especially if the script had not yet been run before.
  ReDim ReferenceArray(1 To i, 1 To 4) As Variant
  Set db = CurrentDb                                  'A relative reference to the current database
  Set rst = db.OpenRecordset(QryName, dbOpenDynaset)  'Opens the current database

  ' On Error GoTo QrySeq_Err
  ' *************CREATE UNIQUE, SERIAL NUMBERS FOR EACH UNIQUE VALUE*****************
  Erase IndexArray                                    'Clear the array from prior runs.  A better function would only erase the results and not the array, which requires re-DIM'ing the definition.
  ReDim IndexArray(1 To i, 1 To 4) As Variant         'The Erase IndexArray causes this to be deleted from above, so it needs to be re-DIM'ed

  For k = 1 To i
    IndexArray(k, 1) = rst.Fields(fldName).Value      'This checks the actual value in the table.  The IndexArray is the final result for each row in query.
    IndexArray(k, 2) = k                              'This assigns the unique reference number
    IndexArray(k, 3) = fldName                        'This is the name of the field passed.  Maybe it could be used multiple times on the same query?
    IndexArray(1, 4) = 1                              'This is the first index value.  It always starts at 1.  There may be an issue re-running it each time.
    ReferenceArray(1, 1) = IndexArray(1, 1)           'These populate the first ReferenceArray with the above values, including the first index of "1"
    ReferenceArray(1, 2) = IndexArray(1, 2)
    ReferenceArray(1, 3) = IndexArray(1, 3)
    ReferenceArray(1, 4) = IndexArray(1, 4)

    '***************This looks for a match in the ReferenceArray so that the matching (x , 4) array value can be assigned later *******************
    UB = UBound(ReferenceArray)     'The ReferenceArray is continually being incremented, but at a different rate than the IndexArray.
    For a = 1 To UB
      MatchFound = False
      If ReferenceArray(a, 1) = IndexArray(k, 1) Then ' this looks at an incrementally-populated array to find a match.
        MatchFound = True
        a = UB                      'This should short-circuit additional lookups.
      End If
    Next

    If MatchFound Then              'If the match is found, find the match and use the value assigned to it in the (m ,4) address of the array
      J = UBound(ReferenceArray)    'Measures the present size of the ReferenceArray.  It is built incrementally as new uniques are identified
      For m = 1 To J                'This does a loop through all existing array entries.  The J value increases with each new unique value in the prior loop.
        If IndexArray(k, 1) = ReferenceArray(m, 1) Then
          IndexArray(k, 4) = ReferenceArray(m, 4)
          m = J                     'This should short-circuit the loop once it finds a match so that it doesn't keep looking.
        End If
      Next
    Else                            'if a match was not found above, add an updated "s" value
      s = s + 1                     'this increments the index number
      IndexArray(k, 4) = s                    ' This populates the array with the new unique's value
      ReferenceArray(k, 1) = IndexArray(k, 1) ' These update the ReferenceArray for future lookups
      ReferenceArray(k, 2) = IndexArray(k, 2)
      ReferenceArray(k, 3) = IndexArray(k, 3)
      ReferenceArray(k, 4) = IndexArray(k, 4)
    End If

    rst.MoveNext
  Next

PrintResults:
  For p = 1 To i
    If IndexArray(p, 1) = fldvalue Then     'I have no idea why fldvalue is sufficient to systematically match to each row in the query, but this works.
      QrySeqCPM = IndexArray(p, 4)
      Set objFileToWrite = CreateObject("Scripting.FileSystemObject").OpenTextFile("D:\TEmp\_test.txt", 8, True)
      objFileToWrite.WriteLine ("Index:     " & k & ", " & IndexArray(p, 1) & ", " & IndexArray(p, 4))
      objFileToWrite.Close
      Set objFileToWrite = Nothing
     End If
  Next

QrySeq_Exit:
  Exit Function

QrySeq_Err:
  MsgBox Err & " : " & Err.Description, , "QrySeqQ"
  x = 1 / 0 'Used for Stopping program during de-bugging
  Resume QrySeq_Exit
End Function

回答1:

I'm not quite sure what you're trying to achieve with that convoluted function of yours. Do you want to print the position in the alphabet for each letter you read from your database? That could be easily achieved with something like this:

filename = "D:\Temp\_test.txt"

Set rst = CurrentDb.OpenRecordset(QryName, dbOpenDynaset)

Set f= CreateObject("Scripting.FileSystemObject").OpenTextFile(filename, 8, True)
Do Until rst.EOF
  v = rst.Fields(fldName).Value
  f.WriteLine v & ", " & (Asc(v) - 96)
  rst.MoveNext
Loop
f.Close

回答2:

"Unique" means "Dictionary" in VBScript. So use one as in:

>> Set d = CreateObject("Scripting.Dictionary")
>> For Each c In Split("a b b b c c d")
>>     If Not d.Exists(c) Then
>>        d(c) = 1 + d.Count
>>     End If
>> Next
>> For Each c In Split("a b b b c c d")
>>     WScript.Echo c, d(c)
>> Next
>>
a 1
b 2
b 2
b 2
c 3
c 3
d 4

where "c 3" means: "c is the 3rd unique item found in the source collection".

回答3:

You can do this with an SQL query and a dash of VBA.

Insert a VBA module into Access, with the following code:

'Module level variables; values will persist between function calls
Dim lastValue As String 
Dim currentIndex As Integer

Public Function GetIndex(Value) As Integer
    If Value <> lastValue Then currentIndex = currentIndex + 1
    GetIndex = currentIndex
End Function

Public Sub Reset()
    lastValue = ""
    currentIndex = 0
End Sub

Then you can use the function as in the following query:

SELECT Table1.Field1, GetIndex([Field1]) AS Expr1
FROM Table1;

Just make sure to call Reset each time before you want to run the query; otherwise the last value will still be preserved from the previous query run.

---

When values later repeat themselves (e.g. a,b,a), the previous code will treat them as a new value. If you want the same value to return the same index for the entire length of a query, you can use a Dictionary:

Dim dict As New Scripting.Dictionary

Public Function GetIndex(Value As String) As Integer
    If Not dict.Exists(Value) Then dict(Value) = UBound(dict.Keys) + 1 'starting from 1
    GetIndex = dict(Value)
End Function

Public Sub Reset()
    Set dict = New Scripting.Dictionary
End Sub