如何一次过滤多个“数组”？

我试图写一个将通过两个给定的arrays，“去年购买的客户”和“今年购买的客户”，并创build三个arrays的子， “去年谁买的”，“今年谁买的”，“哪一年买的”。 既然这两个名单都有两年都买的名字，我正努力将两者区分开来。 到目前为止，守则成功地实现了“两年或两年买入”的arrays，但是我无法实现其他两个并且分开。 任何意见，我要去哪里错将不胜感激。 谢谢！

Sub MergeLists() ' The listSizex variables are list sizes for the various lists (x from 1 to 3). ' The listx arrays contains the members of the lists (again, x from 1 to 3). ' The lists are indexed from 1 to 3 as follows: ' list1 - customers from last year (given data) ' list2 - customers from this year (given data) ' list3 - customers who bought in either or both years (to be found) ' list4 - customers who bought only last year (to be found) ' list5 - customers who bought only this year (to be found) Dim i1 As Integer, i2 As Integer, i3 As Integer, i4 As Integer, i5 As Integer ' counters Dim listSize1 As Integer, listSize2 As Integer, listSize3 As Integer, listSize4 As Integer, listSize5 As Integer Dim list1() As String, list2() As String, list3() As String, list4() As String, list5() As String Dim index1 As Integer, index2 As Integer Dim name1 As String, name2 As String ' Delete the old merged list (if any) in column D. With wsData.Range("D3:F3") Range(.Offset(1, 0), .Offset(1, 0).End(xlDown)).ClearContents End With ' Get the list sizes and the names for the given data in columns A, B. With wsData.Range("A3") listSize1 = Range(.Offset(1, 0), .End(xlDown)).Rows.Count ReDim list1(1 To listSize1) For i1 = 1 To listSize1 list1(i1) = .Offset(i1, 0).Value Next listSize2 = Range(.Offset(1, 1), .Offset(0, 1).End(xlDown)).Rows.Count ReDim list2(1 To listSize2) For i2 = 1 To listSize2 list2(i2) = .Offset(i2, 1).Value Next End With ' Create the merged list. First, initialize new list sizes to be 0. listSize3 = 0 listSize4 = 0 listSize5 = 0 ' Go through list1 and list2 simultaneously. The counters index1 and index2 ' indicate how far down each list we currently are, and name1 and name2 are ' the corresponding customer names. First, initialize index1 and index2. index1 = 1 index2 = 1 ' Keep going until we get past at least one of the lists. Do While index1 <= listSize1 And index2 <= listSize2 name1 = list1(index1) name2 = list2(index2) ' Each step through the loop, add one customer name to the merged list, so ' update the list size and redim list3 right now. listSize3 = listSize3 + 1 listSize4 = listSize4 + 1 listSize5 = listSize5 + 1 ReDim Preserve list3(1 To listSize3) ReDim Preserve list4(1 To listSize4) ReDim Preserve list5(1 To listSize5) ' See which of the two names being compared is first in alphabetical order. ' It becomes the new member of the merged list. Once it's added, go to the ' next name (by updating the index) in the appropriate list. In case of a tie, ' update both indexes. If name1 < name2 Then list3(listSize3) = name1 index1 = index1 + 1 ElseIf name1 > name2 Then list3(listSize3) = name2 index2 = index2 + 1 ElseIf name1 = name2 Then list3(listSize3) = name2 index1 = index1 + 1 index2 = index2 + 1 ElseIf name1 <> name2 Then list4(listSize4) = name1 index1 = index1 + 1 ElseIf name2 <> name1 Then list5(listSize5) = name2 index2 = index2 + 1 End If Loop ' By this time, we're through at least one of the lists (list1 or list2). ' Therefore, add all leftover names from the OTHER list to the merged list. If index1 > listSize1 And index2 <= listSize2 Then ' Some names remain in list2. For i2 = index2 To listSize2 listSize3 = listSize3 + 1 ReDim Preserve list3(1 To listSize3) Next ElseIf index1 <= listSize1 And index2 > listSize2 Then ' Some names remain in list1. For i1 = index1 To listSize1 listSize3 = listSize3 + 1 ReDim Preserve list3(1 To listSize3) Next End If ' Record the merged list in column F of the worksheet. With wsData.Range("F3") For i3 = 1 To listSize3 .Offset(i3, 0).Value = list3(i3) Next End With With wsData.Range("D3") For i4 = 1 To listSize4 .Offset(i4, 0).Value = list3(i4) Next End With With wsData.Range("E3") For i5 = 1 To listSize5 .Offset(i5, 0).Value = list3(i5) Next End With ' End with the cursor in cell A2. wsData.Range("A2").Select End Sub 

Answer 1

我select使用ArrayList来存储客户。 我和Last year的所有客户都填满了LastYear。 如果今年的客户去年买了我从LastYear删除他们，并将其添加到BothYears其他我添加到ThisYear。

 Sub CreateCustomerList() Dim key Dim LastYear As Object, ThisYear As Object, BothYears As Object Set LastYear = CreateObject("System.Collections.ArrayList") Set ThisYear = CreateObject("System.Collections.ArrayList") Set BothYears = CreateObject("System.Collections.ArrayList") With Worksheets("Sheet1") For Each key In .Range("A3", .Range("A" & .Rows.Count).End(xlUp)).Value If Not LastYear.Contains(key) Then LastYear.Add key Next For Each key In .Range("B3", .Range("B" & .Rows.Count).End(xlUp)).Value If LastYear.Contains(key) Then LastYear.Remove key If Not BothYears.Contains(key) Then BothYears.Add key Else ThisYear.Add key End If Next .Range("D3:F" & .Rows.Count).ClearContents .Range("D3").Resize(LastYear.Count).Value = Application.Transpose(LastYear.ToArray) .Range("E3").Resize(ThisYear.Count).Value = Application.Transpose(ThisYear.ToArray) .Range("F3").Resize(BothYears.Count).Value = Application.Transpose(BothYears.ToArray) .Columns.AutoFit End With End Sub 

Answer 2

使用字典来保存值将更容易pipe理：不需要保持resize，Exists方法使得比较值变得简单。

例如

 Sub ListOperations() Dim dLast, dThis, d, dEither, k Set dLast = Dict(Range("A3")) Set dThis = Dict(Range("B3")) Set d = CreateObject("scripting.dictionary") Set dEither = CreateObject("scripting.dictionary") For Each k In dLast If Not dThis.exists(k) Then d(k) = True dEither(k) = True Next k DictToRange d, Range("D3") 'last year only d.RemoveAll For Each k In dThis If Not dLast.exists(k) Then d(k) = True dEither(k) = True Next k DictToRange d, Range("E3") 'This year only d.RemoveAll DictToRange dEither, Range("F3") 'either year End Sub 'Utility: get a dictionary of all unique values, starting at cell cStart ' until the last-occupied cell in that column Function Dict(cStart As Range) Dim c As Range, rng As Range, d As Object Set d = CreateObject("scripting.dictionary") With cStart.Parent Set rng = .Range(cStart, .Cells(.Rows.Count, cStart.Column).End(xlUp)) End With For Each c In rng.Cells If c.Value <> "" Then d(c.Value) = True Next c Set Dict = d End Function 'utility: populate a column with the keys of a dictionary, starting at rng Sub DictToRange(d, rng) If d.Count = 0 Then Exit Sub rng.Resize(d.Count, 1).Value = Application.Transpose(d.keys) End Sub