使用 AutoFilter 运行时的 For Each 循环出错（错误 13）

Question

这就是我想要做的

在 D 列中查找唯一值
通过为每个
对于过滤后的剩余行，我对 E 列和 F 列执行相同的操作。
最后，我只需要复制 K 列中的剩余值并将它们传递到另一个 sheet。

在其中一个循环中，代码给了我一个错误（见下行）。我试图以不同的方式解决它并在网上寻找答案，但我一直无法找到为什么会这样。我得到了 "run-time error '13' Type mismatch"

我非常感谢任何想法。谢谢！！

Sub UniqueVals_f()

'' Variables
Dim i As Variant   ' loop counter
Dim a As Variant   ' loop counter
Dim R As Long
Dim W As Long
Dim Z As Long
Dim gr As Variant  ' group values
Dim ca As Variant  ' category value
Dim cl As Variant  ' class value
Dim CategArray() As Variant
Dim GroupArray() As Variant
Dim ClassArray() As Variant
Dim My_Range As Range
Dim DestSh As Worksheet ' Destination sheet
Dim LastCol As Long
Dim rng As Range
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range


' select range
Set My_Range = Worksheets("ICP").Range("D1", Range("F" & Rows.Count).End(xlUp))
My_Range.Parent.Select
My_Range.Parent.AutoFilterMode = False  'Remove the AutoFilter

' Destination sheet
Set DestSh = Sheets("items")

ca = Application.Transpose(Range("D2", Range("D" & Rows.Count).End(xlUp))) ' extract Categories
With CreateObject("Scripting.Dictionary") 'Categories array
    For Each i In ca  ' <-- This one works fine
        .Item(i) = i
    Next
    CategArray = Application.Transpose(.Keys)  ' getting unique values
End With

'' loop over categories
For R = 1 To UBound(CategArray, 1)
    My_Range.AutoFilter Field:=1, Criteria1:="=" & CategArray(R, 1) ' First Filter
    gr = Application.Transpose(Range("E2", Range("E" & Rows.Count).End(xlUp))) ' extract Groups
    With CreateObject("Scripting.Dictionary")
        For Each i In gr  ' <-- This one works fine too
            .Item(i) = i
        Next
        GroupArray = Application.Transpose(.Keys) ' getting unique values
    End With

    '' Loop over Groups
    For W = 1 To UBound(GroupArray, 1)
        My_Range.AutoFilter Field:=2, Criteria1:="=" & GroupArray(W, 1) ' Second Filter

        lr3 = Cells(Rows.Count, 6).End(xlUp).Row   '' Extract Classes
        cl = Application.Transpose(Range("F2:F" & lr3))
        ' cl = Range("F2:F" & lr3)               ' Alternative way 1
        ' cl = Range("F2:F" & lr3).Value2        ' Alternative way 2
        With CreateObject("Scripting.Dictionary")
            For Each i In cl    '' <-- THE ERROR IS HERE!!!
            'For i = LBound(cl, 1) To UBound(cl, 1) ' Alternative that has the same error
                .Item(i) = i
            Next
            'Next i
            ClassArray = Application.Transpose(.Keys)
        End With

        '' Loop over classes
        For Z = 1 To UBound(ClassArray, 1)
            ' filter classes
            My_Range.AutoFilter Field:=3, Criteria1:="=" & ClassArray(Z, 1) ' Third Filter

            '' Copy items
            Set rng = DestSh.Rows("2:2")
            LastCol = Last(2, rng)

            Range("K2", Range("K" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
            Destination:=DestSh.Cells(2, LastCol + 1)

            My_Range.Parent.AutoFilterMode = False  'Remove the AutoFilter

        Next Z
    Next W
Next R

End Sub

最好的，巴勃罗

Answer 1

如果 lr3 = 2，您的所有替代方案都将不起作用，因为 Range("F2:F" & lr3).Value（.Value 被隐式调用，因为您不使用 Set）将不是数组，而是只是一个值，同样适用于它的 Transpose.

原因是你没有使用Set，所以你得到的是一个值，单个单元格的值不会是数组。我注意到 none 的 Transpose 操作是必要的。所以试试这个快速修复，

删除所有 Transpose 语句并采用原始范围
使用 Set 关键字来获取范围对象而不是数组

.

 Set ca = Range("D2", Range("D" & Rows.Count).End(xlUp))

 Set gr = Range("E2", Range("E" & Rows.Count).End(xlUp))

 Set cl = Range("F2:F" & lr3)

也就是说，这只会解决手头的问题。代码中还有许多其他问题。其中之一是，当您应用 My_Range.Parent.AutoFilterMode = False、 所有过滤器时， 不仅是在内部循环中应用的过滤器。但现在请尝试解决当前问题。

Answer 2

根据 A.S.H 的建议，我通过以下方式改进了代码：

Sub UniqueVals()
Dim a As Variant   ' loop counter
Dim b As Variant   ' loop counter
Dim c As Variant   ' loop counter
Dim Ccolumn As Long
Dim My_Range As Range
Dim MainSh As Worksheet ' Main sheet
Dim DestSh As Worksheet ' Destination sheet
Dim AuxSh  As Worksheet ' Aux sheet
Dim LastCol As Long
Dim CategRg As Excel.Range
Dim GroupRg As Excel.Range
Dim ClassRg As Excel.Range

Application.ScreenUpdating = False
' Destination sheet
Set MainSh = Sheets("ICP")
Set DestSh = Sheets("items")
Set AuxSh = Sheets("Aux")

' select range
Set My_Range = MainSh.Range("D1", Range("F" & Rows.Count).End(xlUp))
My_Range.Parent.Select
My_Range.Parent.AutoFilterMode = False  'Remove the AutoFilter


Ccolumn = 1

'' extract Categories
Range("D2", Range("D1").End(xlDown)).Copy
AuxSh.Range("A1").PasteSpecial Paste:=xlPasteValues
AuxSh.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Set CategRg = AuxSh.Range("A1", AuxSh.Range("A" & Rows.Count).End(xlUp))

For Each a In CategRg.SpecialCells(xlCellTypeVisible)
  My_Range.AutoFilter Field:=1, Criteria1:="=" & a.Value

  MainSh.Range("E2", MainSh.Range("E1").End(xlDown)).Copy
  AuxSh.Range("B1").PasteSpecial Paste:=xlPasteValues
  AuxSh.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlNo
  Set GroupRg = AuxSh.Range("B1", AuxSh.Range("B" & Rows.Count).End(xlUp))

  For Each b In GroupRg.SpecialCells(xlCellTypeVisible)
    My_Range.AutoFilter Field:=2, Criteria1:="=" & b.Value

    MainSh.Range("F2", MainSh.Range("F1").End(xlDown)).Copy
    AuxSh.Range("C1").PasteSpecial Paste:=xlPasteValues
    AuxSh.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
    Set ClassRg = AuxSh.Range("C1", AuxSh.Range("C" & Rows.Count).End(xlUp))

    For Each c In ClassRg.SpecialCells(xlCellTypeVisible)
      My_Range.AutoFilter Field:=3, Criteria1:="=" & c.Value

      MainSh.Range("K1", MainSh.Range("K" & Rows.Count).End(xlUp)).Copy _
      Destination:=DestSh.Cells(1, Ccolumn)

      My_Range.AutoFilter Field:=3  'Remove the AutoFilter

      Ccolumn = Ccolumn + 1
    Next c
    ClassRg.ClearContents
    My_Range.AutoFilter Field:=2    'Remove the AutoFilter
  Next b
  GroupRg.ClearContents
  My_Range.AutoFilter Field:=1    'Remove the AutoFilter
Next a


End Sub

最佳，

使用 AutoFilter 运行时的 For Each 循环出错（错误 13）

Error in For Each loop using AutoFilter runtime (error 13)

excel

vba

loops

unique-values