Question

我发现很多文章贴近我的，但不是我想要的。我正在使用IBM Personal Communications仿真器来收集患者历史数据。患者病史上可能有几页索赔，因此需要收集程序中稍后使用的服务代码并将其保存在一个数组中。删除重复项后，其余代码将存储在下拉框中。

' Copies entire current history screen
MHIScreen = objUNET.autECLPS.GetText(3, 1, 1680)

' Location of the place of service code header
POSLoc = InStr(MHIScreen, "PS  SVC")

' Location of service code
ServLoc = POSLoc + 3

' Used for array index
j = 1
Row = 4

Do
    Serv(j) = Mid(MHIScreen, ServLoc, 6)
    Range("D" & Row).Value = Serv(j)
    ServLoc = ServLoc + 320
    j = j + 1
    Row = Row + 1
Loop Until SMonth > EMonth

此输出可能如下所示：

期望的结果是过滤重复项并最终得到：

这些将被放入一个下拉框供用户选择。我想看一个特定代码所在元素的位置，但是当我添加以下代码行时，我得到0，因为j已经高于最后一个代码的索引而且Serv(j)是空的：< / p>

Result = InStr(Serv(j), "34567")

有没有人可以指导我找到解决方案？

Answer 1

如果我理解正确，您的代码必须执行以下操作：

使用字符串
将元素存储在Excel工作表的单元格中
获取仅包含唯一元素的另一个集合

1。生成具有任意数量元素的集合

最基本的技术是使用Redim Preserve来连续调整数组的大小：

Dim arr(), j
j = 0
Do
    Redim Preserve arr(j)
    arr(j) = Mid(MHIScreen, ServLoc, 6)
    ServLoc = ServLoc + 320
    j = j + 1
Loop Until SMonth > EMonth

但是，如果您使用的是VBA，那么Collection对象是这里的自然选择，因为您不必担心扩展数组的大小：

Dim col As New Collection
Do
    col.Add Mid(MHIScreen, ServLoc, 6)
    ServLoc = ServLoc + 320
Loop Until SMonth > EMonth

如果您使用的是VBScript，那么我建议以相同的方式使用.NET ArrayList（besides its many other benefits）：

Dim al
Set al = CreateObject("System.Collections.ArrayList")
Do
    al.Add Mid(MHIScreen, ServLoc, 6)
    ServLoc = ServLoc + 320
Loop Until SMonth > EMonth

NB。在comment中，您提到了对数组进行排序。 ArrayList优于Collection的一个好处是，它通过Sort method进行了内置排序。如果对值进行排序也是一个目标，我甚至会在VBA中使用ArrayList。

2。将元素存储在Excel工作表的单元格中

如果您正在使用数组，则只需设置适当大小范围的Value属性即可。对于数组：

'app is a variable referring to the Excel Application instance
Dim rng
Set rng = app.Workbooks("MyWorkbook").Worksheets("MyWorksheet").Range("D4").Resize(UBound(arr) + 1, 1)
rng.Value = xlApp.WorksheetFunction.Transpose(arr)

对于集合或ArrayList，您必须手动迭代并写入值。集合的第一个索引是1：

Dim rng As Range, i As Integer
Set rng = ActiveSheet.Range("A1")
For i = 1 To col.Count
    rng.Value = col.Item(i)
    Set rng = rng.Offset(1)
Next

而ArrayList的第一个索引是0：

Dim rng, i
Set rng = Application.Workbooks("MyWorkbook").Worksheets("MyWorksheet").Range("D4")
For i = 0 To al.Count -1
    rng.Value = al.Item(i)
    Set rng = rng.Offset(1)
Next

3。获取仅包含唯一元素的另一个集合

您可以使用Scripting.Dictionary来实现此目的：

Dim dict, x
Set dict  = CreateObject("Scripting.Dictionary")
For Each x In arr 'can be used equally well with a Collection or an ArrayList
    dict(x) = 1 '1 is a dummy value
Next

'prints the keys of the dictionary, which are unique
For Each x In dict.Keys
    Debug.Print x
Next

answer中的代码可简化如下：

只要使用默认的Item属性，就无需检查字典中是否已存在该键。只有在使用Add方法时，才会在添加现有密钥时遇到问题。
您可以直接迭代字典中的键;你不需要第二个阵列：

像这样：

Dim objDictionary, strItem
Set objDictionary = CreateObject("Scripting.Dictionary")
For Each strItem In Serv
    objDictionary(strItem) = 1
Next
For Each strItem In objDictionary.Keys
    Sheet1.RHICodes.AddItem strItem
Next

Answer 2

假设您有一个包含输出的字符串数组，以下代码将产生您想要的结果：

Public Function TestRemoveDupsAndSort()

   'all your preceding code has been removed for clarity

   Do
      Serv(j) = Mid(MHIScreen, ServLoc, 6)
      Range("D" & Row).Value = Serv(j)
      ServLoc = ServLoc + 320
      j = j + 1
      Row = Row + 1
   Loop Until SMonth > EMonth

   result = RemoveDupsAndSort(Serv)
End Function



Public Function RemoveDupsAndSort(data() As String) As String()
   On Error Resume Next

   Dim i As Integer
   Dim j As Integer
   Dim c As Collection
   Dim d() As String

   'sort and remove dups
   Set c = New Collection

   For i = LBound(data) To UBound(data)
      For j = 1 To c.Count
         If data(i) < c(j) Then
            c.Add data(i), data(i), j
         End If
      Next

      If j - 1 = c.Count Then c.Add data(i), data(i)
   Next

   'convert from a collection back to an array
   ReDim d(0 To c.Count - 1)

   For i = 0 To c.Count - 1
      d(i) = c(i + 1)
   Next

   RemoveDupsAndSort= d
End Function

Answer 3

感谢那些伸出援助之手的人。通过他们的共同努力，以及他们试图告诉我的一些额外研究，我提出了一个有效的解决方案。

Dim objDictionary, strItem, intItems, p, strKey, CodeList
Set objDictionary = CreateObject("Scripting.Dictionary")

For Each strItem In Serv
    If Not objDictionary.Exists(strItem) Then
        objDictionary.Add strItem, strItem
    End If
Next

intItems = objDictionary.Count - 1
ReDim arrItems(intItems)
p = 0

For Each strKey In objDictionary.Keys
    arrItems(p) = strKey
    p = p + 1
Next

For Each strItem In arrItems
    With Sheet1.RHICodes
        .AddItem strItem
    End With
Next

现在接受我从IBM PCOMM收集的所有服务代码，将它们输入到一个数组中，使用Scripting.Dictionary对它们进行排序，然后创建另一个只包含我想要的选项但没有重复的数组并输入他们进了一个下拉框。

如何从VBscript / VBA数组中删除重复元素以在Excel

3 个答案:

1。生成具有任意数量元素的集合

2。将元素存储在Excel工作表的单元格中

3。获取仅包含唯一元素的另一个集合