Ошибка цикла For Each с использованием среды выполнения автофильтра (ошибка 13)

Question

Это то, что я пытаюсь сделать

1. Найти уникальные значения в столбце D
2. Цикл по этим значениям путем создания фильтра с каждым
3. с остальными строками после фильтрации я делаю то же самое со столбцами E и F.
4. Наконец, мне просто нужно скопировать оставшиеся значения в столбце 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

Все ваши альтернативы не будут работать, если 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, Все фильтры удалены, не только тот, который применяется во внутреннем цикле. Но попробуйте исправить текущую проблему в данный момент.

Answer 2

Следуя предложениям ASH, я улучшил код следующим образом:

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

Лучший,