如何从VBscript / VBA数组中删除重复的元素在Excel中的下拉框中使用
我发现很多文章靠近我的，但不是我所期待的。 我正在使用IBM个人通信模拟器收集患者历史数据。 患者病史可能有几页声明，所以稍后在程序中使用的服务代码需要收集并保存在一个数组中。 一旦重复被删除，其余的代码将被存储在一个下拉框中。
' 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 这个输出可能看起来像这样：
12345 12345 23456 12345 34567 34567 12345 98765
期望的结果将是通过重复过滤，并以此结束：
12345 23456 34567 98765
这些将被放入一个下拉框供用户select。 我想看看在一个特定的代码将位于元素的位置，但是当我添加下面的代码行时，我得到0，因为j已经高于最后一个代码的索引和Serv(j)是空的：
Result = InStr(Serv(j), "34567")
有没有人可以指导我解决问题？
假设你有一个包含你的输出的string数组，下面的代码将产生你想要的结果：
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
如果我理解正确，您的代码必须执行以下操作：
- 使用任意数量的元素从一个string中生成一个集合
- 将元素存储在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对象就是您自然而然的select，因为您不必担心扩展数组的大小：
Dim col As New Collection Do col.Add Mid(MHIScreen, ServLoc, 6) ServLoc = ServLoc + 320 Loop Until SMonth > EMonth
如果您使用的是VBScript，那么我会build议使用.NET ArrayList （ 除了它的许多其他好处 ）：
Dim al Set al = CreateObject("System.Collections.ArrayList") Do al.Add Mid(MHIScreen, ServLoc, 6) ServLoc = ServLoc + 320 Loop Until SMonth > EMonth
NB。 在你的评论中 ，你提到了sorting数组。 ArrayList优于Collection的好处之一是它通过Sort方法具有内置的Sort 。 如果对值进行sorting也是一个目标，那么即使在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
您的答案中的代码可以简化如下：
- 只要使用默认的
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
感谢那些伸出援助之手。 通过他们的共同努力，以及对他们试图告诉我的一些额外研究，我想出了一个可行的解决scheme。
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收集的所有服务代码，将它们input到一个数组中，使用Scripting.Dictionary对它们进行sorting，然后创build另一个只包含我想要的选项但不重复的数组，然后将它们input到一个下拉列表中框。