Question

这就是我想要做的事情

在D列中找到唯一值
通过为每个
过滤后的剩余行，我对列E和F执行相同的操作。
最后，我只需要复制K列中的剩余值，然后将它们放在不同的工作表中。

在其中一个循环中，代码给出了一个错误（参见下面的行）。我试图以不同的方式解决它并在网上寻找答案，但我无法找到为什么会发生这种情况。我得到了“运行时错误'13'类型不匹配”

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

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

根据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

最好，

Answer 2

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

原因是您没有使用Set，因此您获得了一个值，而单个单元格的值将不是数组。我注意到您的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时，所有过滤器都将被移除，而不仅仅是内循环中应用的过滤器。但是现在尝试解决当前的问题。

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

2 个答案: