我需要从Access数据库生成一个使用标准函数不可用的输出。我做了大量的搜索，但是当我找到示例代码时 - 它最终失败了。所以，我从头开始，从其他人那里汲取经验。尽可能的工作。下面的代码可能非常原始，但它适用于我和数据库中的操作。我真正希望看到的是如何使这些代码更加紧凑和高效。我今天没有处理很多行（＆lt; 20），但我将来也可以。
数据：
期望的结果：
任何人都可以帮助改进/优化此代码吗？请插入评论，以便我了解每一步发生的事情。
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
答案 0 :(得分：0)
我不太确定你想要用你那复杂的功能实现什么目标。您是否要为从数据库中读取的每个字母打印字母表中的位置？这可以通过以下方式轻松实现：
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
答案 1 :(得分：0)
＆＃34;独特＆＃34;在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
其中＆＃34; c 3＆＃34;表示：＆＃34; c是源集合中的第3个唯一项目＆＃34;。
答案 2 :(得分：0)
您可以使用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