VBA，基于标题的高级filter

我有一个先进的filtermacros在Excel中运行，过滤某些列的唯一数据。 我也有一堆工作簿，并具有在这些工作簿中相同的某些标题，但每个工作簿中的标题可能会有不同的列。

因此，标题“Stackoverflow”可能是一个文件中的列F，另一个文件中的列E可能是F列。 我只是想改变我的代码，以通用的东西，所以它得到过滤这个列与一个特定的头，不pipe是哪个工作簿（而不是筛选e：e，f：f等）。 任何input是赞赏。

编辑：这是我的完整的macros，我过滤的部分是更深入一点。

这是我的代码：

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 

testing它：

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

。

编辑：

我对你的代码所做的更改（未经testing）

 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 '---------------------------------------------------------------------------------------