Question

它对我之前的问题的更新，我错过了添加点，说第3列标题数据可能以空格或结尾或其中的任何其他文本开头，因此我们应该尝试使用contains。

计数结果应显示在所有过滤器实体的新工作表中，如3（索引）3（级别）AIUH（实体名称）3（计数），表格末尾附加列，行不会

我为我糟糕的礼仪道歉，并浪费专家的时间再次工作。

以下是以前的参考代码：

Sub xferAscendingFiltered()
Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant

'fill this array with your 40-50 Header values
vFLTRs = Array("AIS", "BBS", "AIUH", _
               "XXX", "YYY", "ZZZ")

With Worksheets("Sheet2")
    If .AutoFilterMode Then .AutoFilterMode = False
    With .Cells(1, 1).CurrentRegion
        'filter on all the values in the array
        .AutoFilter Field:=3, Criteria1:=vFLTRs, Operator:=xlFilterValues

        'walk through the visible rows
        With .Resize(.Rows.Count - 1, 1).Offset(0, 2)
            Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), _
                             SearchOrder:=xlByRows, SearchDirection:=xlNext)
            'seed the rows to delete so Union can be used later
            If rHDR.Row > 1 Then _
                Set rDELs = rHDR

            Do While rHDR.Row > 1

                cnt = 0
                'increase cnt by both visible and hidden cells
                Do
                    cnt = cnt + 1
                Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _
                           Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing

                'transfer the values and clear the original(s)
                With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2)
                    'transfer the values
                    Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
                    'set teh count
                    Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1 - cnt, 3) = cnt
                    Set rDELs = Union(rDELs, .Cells)
                    rHDR.Clear
                End With

                'get next visible Header in column C
                Set rHDR = .FindNext(After:=.Cells(1, 1))
            Loop
            .AutoFilter
        End With

    End With

    'remove the rows
    rDELs.EntireRow.Delete

End With

End Sub

Prior question link:

感谢专家

Answer 1

过滤器代码中的通配符。

要使用变量使用包含，这应该作为查找条件：

这将遍历数组并在匹配旁边放置1，然后将列D过滤为1

Sub xferAscendingFiltered()

    Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant
    '-------------
    Dim rng As Range, cel As Range, LstRw As Long, sh As Worksheet, i    '<<<<<

    Set sh = Sheets("Sheet2")    '<<<<<<<<
    '---------------

    'fill this array with your 40-50 Header values
    vFLTRs = Array("AIUH", "ASC", "ABB", "BBS", "YYY", "ZZZ")
    'vFLTRs = Array("*BBS*", "*ABB*", "*ASC*", "*AIUH*")


    With sh
        '-----------------------------------<<<<<<
        LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
        Set rng = Range("C2:C" & LstRw)

        '----Loop Through Array-----
        For i = LBound(vFLTRs) To UBound(vFLTRs)
            For Each cel In rng.Cells
                If cel Like "*" & vFLTRs(i) & "*" Then
                    cel.Offset(, 1) = 1
                End If
            Next cel
        Next i
        With .Cells(1, 1).CurrentRegion
            'filter on all the values in the array
            .AutoFilter Field:=4, Criteria1:=1
            '-----------------------------------<<<<<<<<<

            'walk through the visible rows
            With .Resize(.Rows.Count - 1, 1).Offset(0, 2)
                Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlNext)

                'seed the rows to delete so Union can be used later
                If rHDR.Row > 1 Then Set rDELs = rHDR

                Do While rHDR.Row > 1

                    cnt = 0

                    'increase cnt by both visible and hidden cells
                    Do
                        cnt = cnt + 1
                    Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _
                         Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing

                    'transfer the values and clear the original(s)
                    With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2)
                        Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
                        Set rDELs = Union(rDELs, .Cells)
                        rHDR.Clear
                    End With

                    'get next visible Header in column C
                    Set rHDR = .FindNext(After:=.Cells(1, 1))
                Loop
                .AutoFilter
            End With

        End With

        'remove the rows
        rDELs.EntireRow.DELETE

    End With

End Sub

查找数据并移至上一个单元格并使用活动单元格值再次查找 - 遇到的问题

1 个答案: