Условное форматирование / проверка заголовков в соответствии с заданным списком заголовков (Excel-VBA) - PullRequest
Новая
       30

Условное форматирование / проверка заголовков в соответствии с заданным списком заголовков (Excel-VBA)

0 голосов
/ 22 октября 2019

Я редко использую VBA и всегда переучиваюсь. Это моя первая публикация.

Я использую OCR для извлечения таблиц из PDF-файлов на отдельные листы (обычно 100-200 вкладок), и у меня есть готовое программирование VBA для консолидации данных на основе значений заголовков. Но заголовки подвержены ошибкам и должны быть проверены в первую очередь. Я хочу запустить макрос 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 будет вКонтролируйте рабочую книгу с установленным списком заголовков, и код будет выполняться на ActiveWorkbook, который будет являться данными многих рабочих листов, но я думаю, что я понял это.

1 Ответ

1 голос
/ 22 октября 2019

Более простой подход: 

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