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行，并且宏运行速度非常慢。行数和Department / Class / Subclass的组合随着时间的推移不会保持不变，所以我希望它能够灵活地每周处理刷新的数据。

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

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中，则高级过滤器对您没有任何帮助   阵列。

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


变量数组，仅包含输入中的唯一元素   数组或范围（或）

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

UniqueItems(ArrayIn, Count)

ArrayIn：范围对象或数组

计数:(可选）如果为True或   省略，该函数返回单个值 - 唯一的数量   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

VBA Multiple For循环用于在层次结构顺序中粘贴唯一标识符

1 个答案:

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

示例4

守则