複数の「アレイ」を一度にフィルタリングする方法は？

Question

"昨年購入した顧客"と "今年購入した顧客"の2つの配列を通過して3つの配列を作成するサブを書き込もうとしています。 「昨年買った人」「今年買った人」「どちらかの年に買った」 2つのリストには、両方の年に買った名前があるので、私は2つを別々の配列に区別するのに苦労しています。これまでのところ、コードは「どちらか/両方の年に買った」配列を正常に達成しましたが、もう一方を達成することはできません。 どこに間違っているのかアドバイスをいただければ幸いです。 ありがとうございました！管理が容易になる値を保持するために辞書を使用し

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

私は顧客を格納するためにArrayListを使用することを選択します。私は最後の年のすべての顧客と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

：必要はリサイズ維持しないように、との方法が存在するが、それは単純な値を比較することができます。

など。

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