针对规定的 header 列表 (Excel-VBA) 的条件格式/测试标头

Question

我很少使用 VBA 并且总是在重新学习。 这是我的第一篇文章。

我正在使用 OCR 将表格从 PDF 提取到单个工作表（通常为 100-200 个选项卡），并且我已准备好 VBA 编程，以根据 header 值合并数据。 但标题容易出错，需要先审查。 我想运行一个 VBA 宏，该宏根据一组列表测试第 1 行中的标题并突出显示那些完全匹配的标题。

我发现在 excel 中使用 VBA （字典方法）来测试列表，这是一个很好的开始，但我正在努力将代码转换为处理行而不是列。 （接下来我计划让它在工作簿中的每个选项卡上运行，但被困在测试阶段）。

这是我当前对从行中提取的原始代码的编辑，但我在If dict2.Exists(vals(i)) Then上得到的下标超出范围

Option Explicit

Sub main3()
    Dim mainRng As Range, list1Rng As Range
    Dim mainDict As New Scripting.Dictionary, list1Dict As New 
    Scripting.Dictionary   'Main is Header and list1 is prescribed header list

    Set mainRng = GetRange(Worksheets("Main"), "1") '<--| get "Main" sheet row "1" range from column A right to last non empty column
    Set list1Rng = GetRange(Worksheets("list1"), "1") '<--| get "list1" sheet row "1" range from column A right to last non empty column

    Set mainDict = GetDictionary(mainRng)
    Set list1Dict = GetDictionary(list1Rng)

    ColorMatchingRange2 list1Rng, list1Dict, mainDict

End Sub

Sub ColorMatchingRange2(rng1 As Range, dict1 As Scripting.Dictionary, dict2 As Scripting.Dictionary)
    Dim unionRng As Range
    Dim vals As Variant
    Dim i As Long

    vals = rng1.Value 'oringinal code transposed with = Application.Transpose(rng1.Value)

    Set unionRng = rng1.Offset(rng1.Rows.Count).Resize(1, 1)
    For i = LBound(vals) To UBound(vals)
        If dict2.Exists(vals(i)) Then Set unionRng = Union(unionRng, rng1(1, i))
    Next i

    Set unionRng = Intersect(unionRng, rng1)
    If Not unionRng Is Nothing Then
        With unionRng.Interior
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
        End With
    End If
End Sub

Function GetDictionary(rng As Range) As Scripting.Dictionary
    Dim dict As New Scripting.Dictionary
    Dim vals As Variant
    Dim i As Long

    vals = rng.Value 'oringinal code transposed with=Application.Transpose(rng.Value)

    On Error Resume Next
    For i = LBound(vals) To UBound(vals)
        dict.Add vals(i), rng(1, i).Address
    Next i
    On Error GoTo 0
    Set GetDictionary = dict
End Function
Function GetRangeRow(ws As Worksheet, rowIndex As String) As Range
    With ws '<--| reference passed worksheet
        Set GetRangeRow = .Range("A" & rowIndex, .Cells(1, .Columns.Count).End(xlToLeft)) '<--| set its row "rowIndex" range from row 1 right to last non empty column
    End With
End Function

更多背景信息，VBA 将在具有设置 header 列表的控制工作簿中，代码将在 ActiveWorkbook 上运行，这将是许多工作表中的数据，但我相信我已经弄清楚了。

Answer 1

更简单的方法：

Sub HighlightMatchedHeaders()

    Dim rngList As Range, c As Range, v
    Dim sht As Worksheet, wb As Workbook

    Set wb = ActiveWorkbook 'or whatever
    'set the lookup list
    With wb.Sheets("list")
        Set rngList = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
    End With

    For Each sht In wb.Worksheets
        'ignore the "list" sheet
        If sht.Name <> rngList.Worksheet.Name Then
            'checking row 1
            For Each c In Application.Intersect(sht.Rows(1), sht.UsedRange).Cells
                v = Trim(c.Value)
                If Len(v) > 0 Then
                    'has a header: check for match
                    If Not IsError(Application.Match(v, rngList, 0)) Then
                        c.Interior.Color = vbRed 'show match
                    End If
                End If
            Next c
        End If
    Next sht

End Sub

Answer 2

试试这个：

Option Explicit

Sub main3()
    Dim mainRng As Range, list1Rng As Range
    Dim mainDict As New Scripting.Dictionary, list1Dict As New Scripting.Dictionary

    Set mainRng = getRange(Worksheets("Main"), "D") '<--| get "Main" sheet column "D" range from row 1 down to last non empty row
    Set list1Rng = getRange(Worksheets("list1"), "A") '<--| get "list1" sheet column "D" range from row 1 down to last non empty row

    Set mainDict = GetDictionary(mainRng)
    Set list1Dict = GetDictionary(list1Rng)

    ColorMatchingRange2 mainRng, mainDict, list1Dict
    ColorMatchingRange2 list1Rng, list1Dict, mainDict

End Sub

Sub ColorMatchingRange2(rng1 As Range, dict1 As Scripting.Dictionary, dict2 As Scripting.Dictionary)
    Dim unionRng As Range
    Dim vals As Variant
    Dim i As Long

    vals = Application.Transpose(rng1.Value)

    Set unionRng = rng1.Offset(rng1.Rows.Count, ).Resize(1, 1)
    For i = LBound(vals) To UBound(vals)
        If dict2.Exists(vals(i)) Then Set unionRng = Union(unionRng, rng1(1, i))
    Next i

    Set unionRng = Intersect(unionRng, rng1)
    If Not unionRng Is Nothing Then
        With unionRng.Interior
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
        End With
    End If
End Sub

Function GetDictionary(rng As Range) As Scripting.Dictionary
    Dim dict As New Scripting.Dictionary
    Dim vals As Variant
    Dim i As Long

    vals = Application.Transpose(rng.Value)

    On Error Resume Next
    For i = LBound(vals) To UBound(vals)
        dict.Add vals(i), rng(1, i).Address
    Next i
    On Error GoTo 0
    Set GetDictionary = dict
End Function

Function getRange(ws As Worksheet, rowIndex As long) As Range
    With ws '<--| reference passed worksheet
        Set getRange = .Range("A" & rowIndex, .Cells(rowIndex, .Columns.Count).End(xlUp)) '<--| set its row "rowIndex" range from row 1 down to last non empty row
    End With
End Function

我没有测试这段代码，我只是从列更改为行。 如果有什么不起作用，请告诉我。