错误对于使用自动筛选运行时（误差13）每个循环

在列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

最佳，巴勃罗

来源

2017-07-07 Pablo Bonilla

你所有的替代品将无法正常工作，如果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,所有的过滤器都被删除，不仅是内循环应用。但请尝试修复当前的问题。

来源

2017-07-07 17:51:13

通过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

最佳，

来源

2017-07-10 17:54:24

这是一个有用的答案，它显示了如何以及在何处单独删除过滤器。 –

错误对于使用自动筛选运行时（误差13）每个循环

回答

相关问题