计数并插入唯一值 - 可这code进行优化？ [英] Count and insert unique values - Can this code be optimized?

问题描述

我需要生成从我的Access数据库的输出使用标准功能，这是不可用的。我做了广泛的搜索，但是当我发现例如code - 它最终失败了。所以，我从头开始，从别人的工作拉在可能的情况。下面的code可能是非常简陋，但它为我工作，并在数据库中运行。我真的很想看到的是如何code可以作出更加紧凑和有效。我今天不处理多行（小于20），但我可以在未来

数据：

• 在
• B
• B
• B
• C
• C
• ð

期望的结果：

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

任何人都可以帮助改进/优化这个code？请插入注释让我明白了什么是发生在每一个步骤。

选项比较数据库 公共职能QrySeqCPM（BYVAL fldvalue，BYVAL fldName作为字符串，BYVAL QryName作为字符串）   建立在这样的查询功能：QrySeqCPM（[字段名]，字段名，查询名称）   昏暗的X，A为整数，我作为整数，S为整数，K为整数，男为整数，N为整数，P为整数，DB数据库，第一个作为记录，J为整数，IndexArray为Variant，MatchFound作为字符串，ReferenceArray为Variant，UB为整数，CURRVAL为Variant   a = 0时   I = 0   S = 1   J =   K = 0   m = 1时   N = 1   p为1   X = 0   MatchFound =假   REDIM ReferenceArray（1，1〜4）为Variant   ReferenceArray（1，1）=虚设'这4项素与虚拟结果，该阵列​​的第一个检查不会错误   ReferenceArray（1，2）= 1   ReferenceArray（1，3）= 1   ReferenceArray（1,4）= 1'这一结果将始终为1，因为它是第一个结果   I = DCOUNT（*，QryName）'计数的行中所得的查询数量。这个我的价值保持整个剧本不变。   REDIM IndexArray（1至I，1至4）作为变式'必以后，以使擦除IndexArray，特别是如果脚本尚未之前运行。   REDIM ReferenceArray（1到I，1〜4）为Variant   设置DB = CurrentDb'相对引用当前数据库   设置RST = db.OpenRecordset（QryName，dbOpenDynaset）打开当前数据库   对错误转到QrySeq_Err   *************创建唯一的序列号，每个唯一值*****************   擦除IndexArray清除以前运行的阵列。一个更好的功能只擦除的结果，而不是数组，需要重新DIM'ing的定义。   REDIM IndexArray（1至I，1至4）作为变式'擦除IndexArray导致此，可以从上删除，所以需要将其重新DIM'ed   对于k = 1到i     IndexArray（K，1）= rst.Fields（fldName）.value的这将检查表中的实际值。的IndexArray是用于查询的每个行的最终结果。     IndexArray（K，2）= K'这种分配唯一的参考号     IndexArray（K，3）= fldName这是通过字段的名称。也许这可以多次使用同一查询？     IndexArray（1,4）= 1'这是第一个索引值。它总是起始于1。有可能是一个问题重新运行每次它。     ReferenceArray（1，1）= IndexArray（1，1）这些填充第一ReferenceArray与上述值，包括1的第一个索引     ReferenceArray（1，2）= IndexArray（1，2）     ReferenceArray（1，3）= IndexArray（1，3）     ReferenceArray（1,4）= IndexArray（1，4）     ***************这看起来在ReferenceArray一场比赛，这样的匹配（X，4）数组值可以在以后分配*********** ********     UB = UBound函数（ReferenceArray）'的ReferenceArray正不断被递增，但在不同的速率比IndexArray。     对于= 1到UB       MatchFound = FALSE       如果ReferenceArray（一，1）= IndexArray（K，1），然后'这看起来处于逐步填充的数组找到匹配。         MatchFound = TRUE         A = UB这应该短路额外的查找。       结束如果     下一个     如果MatchFound然后'如果找到匹配，找到匹配，使用分配给它的值在（男，4）数组的地址       J = UBound函数（ReferenceArray）措施的ReferenceArray的present大小。它是建立逐步为新唯一标识       对于m = 1到J'这确实通过所有现有阵列条目的循环。在J值的增加而在现有循环的每个新的独特的价值。         如果IndexArray（K，1）= ReferenceArray（米，1）。然后           IndexArray（K，4）= ReferenceArray（米，4）           M = J'这应该短路，一旦找到匹配，使其不继续找循环。         结束如果       下一个     否则如果没有上面找到匹配，添加一个更新的S值       S = S + 1这一递增的索引号       IndexArray（K，4）= S'这填充新的独特的价值数组       ReferenceArray（K，1）= IndexArray（K，1）'，这些更新的ReferenceArray为将来的查找       ReferenceArray（K，2）= IndexArray（K，2）       ReferenceArray（K，3）= IndexArray（K，3）       ReferenceArray（K，4）= IndexArray（K，4）     结束如果     rst.MoveNext   下一个 PrintResults：   对于p = 1至i     如果IndexArray（P，1）= fldvalue然后'我不知道为什么fldvalue足以满足系统在查询中的每一行，但这个工程。       QrySeqCPM = IndexArray（对，4）       设置objFileToWrite =的CreateObject（Scripting.FileSystemObject的）的OpenTextFile。（D：\ TEMP \ _test.txt，8，真）       objFileToWrite.WriteLine（索引：与＆amp; K＆安培;，＆安培; IndexArray（对，1）及，＆安培; IndexArray（对，4））       objFileToWrite.Close       设置objFileToWrite =什么      结束如果   下一个 QrySeq_Exit：   退出功能 QrySeq_Err：   MSGBOX犯错和放大器; ：＆安培; Err.Description它将，QrySeqQ   X = 1/0'用于在去窃听停止程序   简历QrySeq_Exit 端功能

解决方案

您可以使用一个SQL查询和VBA少许做到这一点。

插入一个VBA模块插入访问，具有以下code：

 模块级变量;值将函数调用之间仍然存在
昏暗lastValue作为字符串
昏暗CURRENTINDEX作为整数

公共功能GetIndex（值）作为整数
    如果值小于;＆GT; lastValue然后CURRENTINDEX = CURRENTINDEX + 1
    GetIndex = CURRENTINDEX
端功能

公用Sub复位（）
    lastValue =
    CURRENTINDEX = 0
结束小组
 

然后就可以使用该功能在下面的查询：

  SELECT Table1.Field1，GetIndex（[字段1]）作为表达式1
从表1;
 

只要确保调用重置要运行查询之前，每一次;否则，最后一个值将仍然是从previous查询运行preserved。

---

当值后重复自己（如 A ， B ， A ），在previous code将其视为新的价值。如果你想相同的值返回相同的索引查询的整个长度，你可以使用词典：

 昏暗的字典作为新的Scripting.Dictionary

公共功能GetIndex（值作为字符串）作为整数
    如果不dict.Exists（值），字典（值）= UBound函数（dict.Keys）+ 1'从1开始
    GetIndex =字典（值）
端功能

公用Sub复位（）
    设置字典=新的Scripting.Dictionary
结束小组
 

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

解决方案

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

这篇关于计数并插入唯一值 - 可这code进行优化？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！