我正在尝试编写一个子程序,它将通过两个给定的阵列,“去年购买的客户”和“今年购买的客户”并创建三个阵列; “谁去年买了”,“谁买了今年”,“和任何一年买”。由于这两个给定的列表都有两年内购买的名称,因此我很难将两者分成单独的数组。到目前为止,守则成功实现了“在两年/两年内购买”的阵列,但我无法实现其他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
答案 0 :(得分:2)
我选择使用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
答案 1 :(得分:0)
使用字典来保存值将更容易管理:无需继续调整大小,并且Exists方法使得比较值变得简单。
E.g。
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