宏观需要清理

Question

我有一本我一直在写的工作簿。此工作簿包含 3 张信息，可帮助通过 excel 索引和匹配函数以及其他函数填充 MASTER 表。 MASTER 表上的 A2 单元格是名称的下拉框。选择每个名称时，链接到一个按钮的宏有助于汇总信息，然后另一个按钮将工作表复制并粘贴到工作簿中的新工作表中。我的问题是关于总结信息的宏。作为宏的新手，我将其与在 Internet 上收集的信息放在一起。我注意到它在使用时隐藏了一些行，这不好并且工作得非常慢。此外，不是很重要，它会将糊状物放置在范围内的任何位置。甚至有时会分开，例如在 E14 和 E16 上而不是 E14 和 E15。我确信有更好的方法来编写这个宏，任何帮助和教育都将不胜感激。

Sub UniqueValues()

Dim ws As Worksheet

'list states for install & service

Application.ScreenUpdating = False
Set ws = Sheets("MASTER")
ws.Range("D94:D144").AdvancedFilter Action:=x1FilterInPlace, Unique:=True
Range("D94:D144").Copy
ws.Range("E14:E19").PasteSpecial x1Values
Application.CutCopyMode = False
Application.ScreenUpdating = True

'list states for overrides

Application.ScreenUpdating = False
Set ws = Sheets("MASTER")
ws.Range("D147:D246")AdvancedFilter Action:=x1FilterInPlace, Unique:=True
Range("D147:D246").Copy
ws.Range("E21:E26").PasteSpecial x1Values
Application.CutCopyMode = False
Application.ScreenUpdating = True

'lists states for licenses

Application.ScreenUpdating = False
Set ws = Sheets("MASTER")
ws.Range("D249:D298").AdvancedFilter Action:=x1FilterInPlace, Unique:=True
Range("D249:D298").Copy
ws.Range("E35:E38").PasteSpecial x1Values
Application.CutCopyMode = False
Application.ScreenUpdating = True

'lists states for commissions

Application.ScreenUpdating = False
Set ws = Sheets("MASTER")
ws.Range("D301:D327").AdvancedFilter Action:=x1FilterInPlace, Unique:=True
Range("D301:D327").Copy
ws.Range("E28:E33").PasteSpecial x1Values
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Answer 1

“就地”过滤器 + 复制粘贴会很慢。如果你想改进你的代码，你可以使用字典（在 Microsoft Scripting Runtime 中可用）

Sub getUniquesValues(output As Range, cells As Range)
    Dim cell As Range
    Dim knownValues As New Dictionary

    For Each cell In cells
        If Not knownValues.Exists(cell.Value) Then
            output = cell.Value
            Set output = output.Offset(1, 0)
            knownValues.Add cell.Value, 1
        End If
    Next
End Sub

那么你所要做的就是以这种方式调用 sub：

Sub ImprovedUniqueValues()
    Dim cell As Range, output As Range
    Dim ws As Worksheet

    Set ws = Sheets("MASTER")
    Set output = ws.Range("E19")

    getUniquesValues output, ws.Range("D94", ws.Range("D94").End(xlDown))
    ....
End Sub