VBA，基于标题的高级筛选器 [英] VBA, Advanced Filter Based on Header

问题描述

我有一个在excel中运行的高级过滤器宏，该宏可过滤某些列以获取唯一数据.我也有一堆工作簿，并且在这些工作簿中有某些相同的标题，但是每个工作簿中的标题在列中可能会有所不同.

I have an advanced filter macro to run in excel that filters certain columns for unique data. I have a bunch of workbooks as well, and have certain headers that are identical across these workbooks, but headers in each workbook may differ in columns.

因此，标头'Stackoverflow'在一个文件中可能是F列，在另一个文件中是E列.我只想将我的代码更改为通用代码，这样无论使用哪个工作簿，它都可以使用特定的标题过滤此列(而不是过滤e:e，f:f等).任何输入表示赞赏.

So header 'Stackoverflow' may be Column F in one file, and Column E in another. I just want to alter my code to something generic so it gets filter this column with a particular header no matter which workbook (Instead of filtering e:e, f:f, etc). any input is appreciated.

这是我的完整宏，我进行过滤的部分还很远.

this is my full macro, the part where I filter is a bit further down.

这是我的代码:

    Sub stkoverflow()
Dim ws As Worksheet
Dim wks As Excel.Worksheet
Dim wksSummary As Excel.Worksheet
Dim y As Range
Dim intRow As Long, i As Integer
Dim r As Range, lr As Long, myrg As Range

For Each ws In ActiveWorkbook.Worksheets
    ws.Activate

    lr = Cells(Rows.Count, "c").End(3).Row
    Set myrg = Range("f2:f" & lr)
    myrg.ClearContents
    myrg.Formula = "=IFERROR(LEFT(e2,FIND(""_"",e2,1)-1),LEFT(e2,2))"
    myrg.Value = myrg.Value

    Range("f1").Value = "Test"
Next ws

On Error Resume Next
Set wksSummary = Excel.ActiveWorkbook.Worksheets("Unique data")
On Error GoTo 0

If wksSummary Is Nothing Then
    Set wksSummary = Excel.ActiveWorkbook.Worksheets.Add
    wksSummary.Name = "Unique data"
End If
For Each wks In Excel.ActiveWorkbook.Worksheets
    With wksSummary
        If wks.Name <> .Name Then
             '                THIS SECTION OF CODE IS POINTLESS. 'r' WILL ALWAYS BE DECLARED IRRESPECTIVE OF THE 'IF' STATEMENT
             '                If Application.WorksheetFunction.CountA(wks.Range("f:f")) Then
             '                    Dim r As Range
             '                End If

            With wksSummary
                If wks.Name <> .Name Then
                    If Application.WorksheetFunction.CountA(wks.Range("a:a")) Then
                        Set r = .Cells(.Cells(.Rows.Count, 4).End(xlUp).Row + 1, 4)
                        Set y = .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row + 0, 5)

                        If WorksheetFunction.CountA(wks.Range("f:f")) > 1 Then
                            If WorksheetFunction.CountA(wks.Range("a:a")) > 1 Then
                                wks.Range("f:f").AdvancedFilter xlFilterCopy, , r, True
                                wks.Range("a:a").AdvancedFilter xlFilterCopy, , y, True
                            Else
                                r = "N/A"
                                y = "N/A"
                            End If
                        End If

                        r.Delete xlShiftUp
                    End If

                     ' I HAVE INSERTED BLOCK ENDINGS FROM HERE, AND CHANGED THE INDENTING OF THE SUBSEQUENT CODE TO FIT
                     ' The next 4 lines are all inserted
                End If
            End With
        End If
    End With

     ' I have removed 4 x 'tab' indents from all of the code below
Next wks

Range("A1").Value = "File Name "
Range("B1").Value = "Sheet Name "
Range("D1").Value = "Scenario Name"

intRow = 2
For i = 1 To Sheets.Count
    If Sheets(i).Name <> ActiveSheet.Name Then
        Cells(intRow, 2) = Sheets(i).Name
        Cells(intRow, 1) = ActiveWorkbook.Name
        intRow = intRow + 1
    End If
Next i
 End Sub

推荐答案

这里是获取标头的列号的一种方法

Here is one way to get the column number of a header

Option Explicit

Public Function hdrCol(ByRef ws As Worksheet, _
                       ByVal hdrName As String, _
                       Optional hdrRow As Long = 1, _
                       Optional matchLtrCase As Boolean = True) As Long

    Dim found As Range, foundCol As Long

    If Not ws Is Nothing Then

        hdrRow = Abs(hdrRow)
        hdrName = Trim(hdrName)

        If hdrRow > 0 And Len(hdrName) > 0 Then

            Set found = ws.UsedRange.Rows.Find(What:=hdrName, _
                                               LookIn:=xlFormulas, _
                                               LookAt:=xlWhole, _
                                               SearchOrder:=xlByColumns, _
                                               SearchDirection:=xlNext, _
                                               matchCase:=matchLtrCase)

            If Not found Is Nothing Then foundCol = found.Column

        End If
    End If

    hdrCol = foundCol

End Function

要对其进行测试:

Public Sub testHeader()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        MsgBox hdrCol(ws, "Stackoverflow")
    Next
End Sub

.

我要对您的代码进行的更改(未经测试)

Changes I'd make to your code (not tested)

Option Explicit

Public Sub stkoverflow()
    Dim wb As Workbook, ws As Worksheet, wsSummary As Worksheet, lr As Long
    Dim y As Range, r As Range, thisRow As Long, colA As Range, colF As Range

    Set wb = ActiveWorkbook
    For Each ws In wb.Worksheets
        lr = ws.Cells(ws.Rows.Count, "C").End(3).Row
        With ws.Range("F2:F" & lr)
            .ClearContents
            .Formula = "=IFERROR(LEFT(E2,FIND(""_"",E2,1)-1),LEFT(E2,2))"
            .Value = .Value
        End With
        ws.Range("F1").Value = "Test"
        If ws.Name = "Unique data" Then Set wsSummary = ws
    Next ws

    If wsSummary Is Nothing Then
        Set wsSummary = wb.Worksheets.Add
        wsSummary.Name = "Unique data"
    End If

    For Each ws In wb.Worksheets
        With wsSummary
            If ws.Name <> .Name Then
                '...
                'Determine dynamic columns based on header
                Set colA = ws.Columns(hdrCol(ws, "YOUR_HEADER_NAME_FOR_COL_A", 1, True))
                Set colF = ws.Columns(hdrCol(ws, "YOUR_HEADER_NAME_FOR_COL_F", 1, True))

                If ws.Name <> .Name Then
                    If Application.WorksheetFunction.CountA(colA) Then
                        Set r = .Cells(.Cells(.Rows.Count, 4).End(xlUp).Row + 1, 4)
                        Set y = .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row + 0, 5)
                        If WorksheetFunction.CountA(colF) > 1 Then
                            If WorksheetFunction.CountA(colA) > 1 Then
                                colF.AdvancedFilter xlFilterCopy, , r, True
                                colA.AdvancedFilter xlFilterCopy, , y, True
                            Else
                                r = "N/A"
                                y = "N/A"
                            End If
                        End If
                        r.Delete xlShiftUp
                    End If
                    '...
                End If
            End If
        End With
        '...
    Next ws

    With ActiveSheet    'not sure about the ActiveSheet...
        .Range("A1").Value = "File Name "
        .Range("B1").Value = "Sheet Name "
        .Range("D1").Value = "Scenario Name"
    End With

    thisRow = 2
    For Each ws In wb.Worksheets
        If ws.Name <> ActiveSheet.Name Then
            ActiveSheet.Cells(thisRow, 2) = ws.Name
            ActiveSheet.Cells(thisRow, 1) = wb.Name
            thisRow = thisRow + 1
        End If
    Next

End Sub

'---------------------------------------------------------------------------------------

这篇关于VBA，基于标题的高级筛选器的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！