Подсчитайте и вставьте уникальные значения. Можно ли оптимизировать этот код?

Мне нужно было создать выход из моей базы данных Access, которая была недоступна с использованием стандартных функций. Я сделал обширный поиск, но когда я нашел пример кода - он в конечном итоге не удался. Итак, я начал с нуля, по возможности, выполняя работу других. Код ниже, вероятно, очень примитивен, но он работает для меня и операции в базе данных. Мне бы очень хотелось увидеть, как этот код можно сделать более компактным и эффективным. Сегодня я не занимаюсь многими строками (< 20), но я мог бы в будущем.

Данные:

a
б
б
б
с
с
д

Желаемый результат:

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

Я не совсем уверен, чего вы пытаетесь достичь с помощью этой извилистой функции. Вы хотите напечатать позицию в алфавите для каждой буквы, которую вы читаете из своей базы данных? Это может быть легко достигнуто с помощью следующего:

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

"Уникальный" означает "Словарь" в VBScript. Поэтому используйте его как:

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

Вы можете сделать это с помощью 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