Question

我的代码工作正常，但它会过滤每一行而不管值是什么，而且我的行包含重复项。

我希望使用唯一值过滤每一行，而不是每行都过滤。

Dim LastRow As Long
Dim rng As Range
Dim i As Variant

LastRow = Range("K17:K" & Rows.Count).End(xlUp).Row

Set rng = Worksheets(1).Range("K16:K4000")


For Each i In rng

    With rng.AutoFilter(1, i)
        Worksheets(1).Activate
        ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 1).Select
        Selection.copy
        Range("A7:A9").Select
        ActiveSheet.Paste
        Range("A6:F9").copy
        Worksheets(3).Activate
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        ActiveSheet.Paste

    End With

Next i

Answer 1

根据K16：K4000中的值构建字典，并使用唯一键作为过滤条件。

Dim dict As Object, vals As Variant, k As Variant
Dim rng As Range, lastRow As Long, i As Variant

Set dict = CreateObject("scripting.dictionary")
dict.comparemode = vbTextCompare

Set rng = Worksheets(1).Range("K16:K4000")
vals = rng.Value

For k = LBound(vals, 1) To UBound(vals, 1)
    dict.Item(vals(k, 1)) = vbNullString
Next k

For Each k In dict.keys
    'Debug.Print k
    With rng.AutoFilter(1, k)
        Worksheets(1).Activate
        ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 1).Select
        Selection.Copy
        Range("A7:A9").Select
        ActiveSheet.Paste
        Range("A6:F9").Copy
        Worksheets(3).Activate
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        ActiveSheet.Paste
    End With
Next k

Autofilter接下来没有重复值

1 个答案: