Excel VBA:从多个范围变量创建二维数组(无重复)

时间:2014-09-03 23:11:28

标签: arrays excel vba excel-vba

我有六个变量范围:A_backup,B_backup,C_backup,D_backup,E_backup,F_backup

每个范围变量是一列,行数可变(一些有3个,其他有5个等)

我想从这些范围中取出每个单元格并将它们添加到名为Combined_backups的新单列数组中。如果它是一个重复的字符串值,我还想避免添加一个单元格。

这是我尝试过的。遇到Combined_backups.RemoveDuplicates的问题。我应该为组合数组创建一个新范围,应用RemoveDuplicates,然后创建一个新的最终数组?另外,测试我的Combined_backups数组实际上已成为我希望的数组的最佳方法是什么?

Dim Combined_backups() As Variant

'add A_backup
Dim j As Integer
j = A_backup.Rows.Count

ReDim Preserve Combined_backups(j)

For i = 0 To j - 1
    Combined_backups(i) = A_backup.Item(i + 1)
Next i

'add B_backup
Dim k As Integer
k = B_backup.Rows.Count

ReDim Preserve Combined_backups(j + k)

For i = 0 To k - 1
    Combined_backups(i) = B_backup.Item(i + 1)
Next i

'add C_backup
Dim l As Integer
l = C_backup.Rows.Count

ReDim Preserve Combined_backups(j + k + l)

For i = 0 To l - 1
    Combined_backups(i) = C_backup.Item(i + 1)
Next i

'add D_backup
Dim m As Integer
m = D_backup.Rows.Count

ReDim Preserve Combined_backups(j + k + l + m)

For i = 0 To m - 1
    Combined_backups(i) = D_backup.Item(i + 1)
Next i

'add E_backup
Dim n As Integer
n = E_backup.Rows.Count

ReDim Preserve Combined_backups(j + k + l + m + n)

For i = 0 To n - 1
    Combined_backups(i) = E_backup.Item(i + 1)
Next i

'add F_backup
Dim o As Integer
o = F_backup.Rows.Count

ReDim Preserve Combined_backups(j + k + l + m + n + o)

For i = 0 To o - 1
    Combined_backups(i) = F_backup.Item(i + 1)
Next i

'elminate duplicates from Combined_backups
Combined_backups.RemoveDuplicates

谢谢!

1 个答案:

答案 0 :(得分:2)

这是使用Collection对象的不同方法。我们首先将所有东西都放入一个集合中,利用它的优势来拒绝重复;然后我们将集合对象放入“结果”数组中,并将其写回工作表。假设您的各种数组是命名范围而不是范围对象,但您应该能够根据需要进行调整:

选项明确

Sub UniqueArray()
    Dim vSrc As Variant
    Dim colStrings As Collection
    Dim vVarRanges As Variant
    Dim vResults() As Variant
    Dim S As String
    Dim I As Long, J As Long, K As Long

vVarRanges = VBA.Array("A_backup", "B_backup", "C_backup", "D_backup", "E_backup", "F_backup")

Set colStrings = New Collection
On Error Resume Next 'So collection will omit any duplicates instead of causing an error
For I = 0 To UBound(vVarRanges)
    vSrc = Range(vVarRanges(I))
    For J = 1 To UBound(vSrc, 1)
        S = vSrc(J, 1)
        If Len(S) > 0 Then _
            colStrings.Add Item:=S, Key:=CStr(S)
    Next J
Next I
On Error GoTo 0

'Now create results array
ReDim vResults(1 To colStrings.Count, 1 To 1)
For I = 1 To colStrings.Count
    vResults(I, 1) = colStrings(I)
Next I

'Write the results someplace

With Worksheets("sheet4").Range("A1").Resize(rowsize:=UBound(vResults))
    .EntireColumn.Clear
    .Value = vResults
End With

End Sub