计算并插入唯一值 - 可以优化此代码吗？

Question

我需要从我的 Access 数据库生成一个使用标准函数不可用的输出。我进行了广泛的搜索，但是当我找到示例代码时 - 它最终失败了。所以，我从头开始，尽可能从别人的工作中汲取灵感。下面的代码可能非常原始，但它适用于我和数据库中的操作。我真正想看到的是如何使这段代码更加紧凑和高效。我今天不会处理很多行（

数据：

• 一个
• b
• b
• b
• c
• c
• d

想要的结果：

• 一个，1个
• b, 2
• b, 2
• b, 2
• c, 3
• c, 3
• d, 4

谁能帮助完善/优化这段代码？请插入 cmets，以便我了解每一步发生的情况。

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

Answer 1

我不太确定你想用你那个复杂的功能来实现什么。您想打印从数据库中读取的每个字母在字母表中的位置吗？这可以通过以下方式轻松实现：

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

Answer 2

“唯一”在 VBScript 中表示 "Dictionary"。所以使用一个：

>> 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

其中“c 3”表示：“c 是在源集合中找到的第 3 个唯一项”。

Answer 3

您可以使用 SQL 查询和少量 VBA 来完成此操作。

在 Access 中插入一个 VBA 模块，代码如下：

'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

然后您可以使用如下查询中的函数：

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

只要确保每次运行查询之前都调用Reset；否则最后一个值仍将保留从上一次查询运行。

---

当值稍后重复时（例如a,b,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