VBA 多个 For 循环以按层次顺序粘贴唯一性

Question

我创建了一个宏来运行连续的 FOR 循环以从多个列中选择唯一值并按层次顺序粘贴它们的名称。

例如，

Area   Region   Land    Number      Name    Department      Class   Subclass  
North America   USA FL  10101372    Store 1 CATCH-ALL       TAXABLE CATCH ALL  
North America   USA FL  10101372    Store 1 COLLECTIBLES    2D      ART SKETCH  
North America   USA FL  10101372    Store 1 COLLECTIBLES    2D      DLX/PETITE  
North America   USA FL  10101372    Store 1 COLLECTIBLES    2D      FINE ART  
North America   USA FL  10101372    Store 1 COLLECTIBLES    2D      FRAMING  

会产生：

USA   
FL    
Store 1  
CATCH-ALL  
TAXABLE  
CATCH ALL  
COLLECTIBLES  
2D  
ART SKETCH  
DLX/PETITE  
FINE ART  
FRAMING  

子类列在正确的类下，正确的部门下的类等。

它适用于我的小型测试数据集，但我的最终输入将至少有 5000 行，并且宏运行非常缓慢。行数和部门/类/子类的组合不会随着时间的推移保持不变，所以我希望它能够灵活地处理每周刷新的数据。

我可以对循环或代码的其他部分进行任何改进以使其运行得更快吗？

Option Explicit
Sub GetUniques()
Application.DisplayStatusBar = False
Dim d As Object, c As Variant, c2 As Variant, c3 As Variant, c4 As Variant,   c5 As Variant, c6 As Variant, c7 As Variant, i As Long, i2 As Long, i3 As Long,    i4 As Long, i5 As Long, i6 As Long, i7 As Long, lr As Long, ws As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Set ws = Sheets("Raw Wonderground")
lr = Cells(Rows.Count, 1).End(xlUp).Row

c = ws.Range("B3:B" & lr)
For i = 1 To UBound(c, 1)
  d(c(i, 1)) = 1
c2 = ws.Range("C3:C" & lr)
For i2 = 1 To UBound(c2, 1)
 d(c2(i, 1)) = 1
c3 = ws.Range("E3:E" & lr)
For i3 = 1 To UBound(c3, 1)
 d(c3(i, 1)) = 1
c4 = ws.Range("F3:F" & lr)
For i4 = 1 To UBound(c4, 1)
 d(c4(i, 1)) = 1
c5 = ws.Range("G3:G" & lr)
For i5 = 1 To UBound(c5, 1)
 d(c5(i, 1)) = 1
c6 = ws.Range("H3:H" & lr)
For i6 = 1 To UBound(c6, 1)
 d(c6(i, 1)) = 1
 Next i6
 Next i5
 Next i4
 Next i3
 Next i2
 Next i
ws.Range("M2").Resize(d.Count) = Application.Transpose(d.keys)


End Sub

Answer 1

This looks like your problem, see exemple 4:

识别数组或范围中的唯一值

您是否曾经只需要处理某个范围内的独特项目？如果 您的数据是数据库的形式，您可以使用高级 过滤命令以从单个列中提取唯一项。但 如果您的数据跨越多个列，则高级筛选器将不起作用。和 如果您的数据在 VBA 中，高级过滤器对您没有任何好处 数组。

在本文档中，我提出了一个 VBA 函数，它接受 工作表范围对象或 VBA 数组。该函数返回：

• 仅由输入中的唯一元素组成的变体数组 数组或范围（或）
• 单个值：中唯一元素的数量 输入数组或范围。这是 UniqueItems 的语法 功能（在本文档末尾列出）：

UniqueItems(ArrayIn, Count)

• ArrayIn：范围对象或数组
• 计数：（可选）如果为真或 省略，函数返回单个值——唯一的数量 ArrayIn 中的项目。如果为 False，则函数返回一个数组 由 ArrayIn 中的唯一项组成。

---

[...]

---

示例 4

要显示范围内的唯一项，您必须数组输入 将公式放入一系列单元格中（使用 Ctrl+Shift+Enter）。的结果 UniqueItems 函数是一个水平数组。如果你想 显示列中的唯一值，您可以使用 TRANSPOSE 功能。下面的公式（这是数组输入到垂直 range) 返回 A1:D21 中的唯一项。

=TRANSPOSE(UniqueItems(A1:D21,FALSE))

代码

选项基础 1

Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
'   Accepts an array or range as input
'   If Count = True or is missing, the function returns the number of unique elements
'   If Count = False, the function returns a variant array of unique elements
    Dim Unique() As Variant ' array that holds the unique items
    Dim Element As Variant
    Dim i As Integer
    Dim FoundMatch As Boolean
'   If 2nd argument is missing, assign default value
    If IsMissing(Count) Then Count = True
'   Counter for number of unique elements
    NumUnique = 0
'   Loop thru the input array
    For Each Element In ArrayIn
        FoundMatch = False
'       Has item been added yet?
        For i = 1 To NumUnique
            If Element = Unique(i) Then
                FoundMatch = True
                Exit For '(exit loop)
            End If
        Next i
AddItem:
'       If not in list, add the item to unique list
        If Not FoundMatch And Not IsEmpty(Element) Then
            NumUnique = NumUnique + 1
            ReDim Preserve Unique(NumUnique)
            Unique(NumUnique) = Element
        End If
    Next Element
'   Assign a value to the function
    If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function