Question

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

所以标题＆＃39; Stackoverflow＆＃39;可以是一个文件中的列F，另一个文件中的列E.我只是想将我的代码更改为通用的代码，因此无论使用哪个工作簿（而不是过滤e：e，f：f等），它都会使用特定的头来过滤此列。任何输入都表示赞赏。

编辑：这是我的完整宏，我过滤的部分更进一步。

这是我的代码：

    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

Answer 1

以下是获取标题列号的一种方法

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

修改

我对您的代码进行的更改（未经测试）

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，基于标题的高级过滤器

1 个答案: