这就是我想要做的
- 在 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
最好的,巴勃罗