计数并插入唯一值 - 此代码是否可以优化？

Question

我需要从我的Access数据库使用标准函数不可用来生成输出。我做了大量的搜索，但是当我找到示例代码时 - 它最终失败了。所以，我从头开始，在可能的情况下从别人的工作中抽身而出。下面的代码可能非常原始，但它适用于我和数据库中的操作。我真正想看到的是如何使这个代码更加紧凑和高效。我今天没有处理很多线路（< 20），但我可以在将来。

数据：

• 一个
• b
• b
• b
• Ç
• Ç
• d

期望的结果：

• 一个，1个
• B，2
• B，2
• B，2
• C，3
• C，3
• d，4

任何人都可以帮助改进/优化此代码吗？请插入评论，以便我了解每一步发生的情况。

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来做到这一点。

插入一个VBA模块到Access，用下面的代码：

'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