Блог

Я пытаюсь написать подраздел, который будет просматривать два заданных массива: «клиенты, которые приобрели в прошлом году» и «клиенты, которые приобрели в этом году», и создать ТРИ массива; «кто купил в прошлом году», «кто купил в этом году» и «купил в любом году». Поскольку в двух приведенных списках есть имена, которые покупали в оба года, я изо всех сил пытаюсь разделить их на отдельные массивы. Пока что код успешно достигает массива, «купленного в один / оба года», но я не могу достичь двух других и разделить. Буду признателен за любой совет о том, где я ошибаюсь. Спасибо!

 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
  

Я решил использовать ArrayList для хранения клиентов. Я заполнил прошлый год всеми клиентами прошлых лет. Если клиенты этого года купили в прошлом году, я удалил их из прошлогоднего и добавил это к обоим годам, еще я добавил к этому году.

 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" amp; .Rows.Count).End(xlUp)).Value
            If Not LastYear.Contains(key) Then LastYear.Add key
        Next

        For Each key In .Range("B3", .Range("B" amp; .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" amp; .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
  

Было бы проще управлять использованием словарей для хранения значений: не нужно постоянно изменять размер, а существующие методы упрощают сравнение значений.

Например.

 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