0

这就是我想要做的

  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

最好的，巴勃罗

4

2 回答 2

1

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

最好的，

于 2017-07-10T17:54:24.803 回答
0

如果 ，您的所有替代方案都将不起作用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-07T17:51:13.070 回答