Using a macro to find matching numbers within tables

**lar9149** · 03-28-2024, 05:53 PM

Hello all hope every is doing well.

I was wondering if there is a way to create a macro (or formula?) to highlight numbers in tables above it that match the numbers within the specified column and table.

In the sample, in the the table at the bottom (Labeled TABLE in red), I highlighted the numbers in the column heading labeled t11 in red and highlighted in red the numbers that match those numbers in the 3 tables above it (hopefully I didn't miss any).

Is there a macro that would highlight these numbers automatically in the above 3 tables.

Note: the macro would have to be flexible because sometimes I may want to match the numbers in any other column like those in column heading t13 (highlighted blue to differ it from the previous numbers) or any other column in the table.

A second sample (stock comparison 2) has been added to show the tables in different positions and matching a different header (t15)

**Artik** · 03-28-2024, 07:18 PM

Below not very effective macro, but in small areas perhaps enough.

Sub AAA()
    Dim rngS As Range
    Dim rngT As Range
    Dim rng As Range
    Dim rng1 As Range

    Set rngS = Range("B37").CurrentRegion

    With rngS
        Set rngS = .Offset(1).Resize(.Rows.Count - 1)
    End With

    Set rngT = Range("B7").CurrentRegion

    For Each rng In rngS
        If rng.Font.ColorIndex <> xlAutomatic Then
            For Each rng1 In rngT
                If rng1.Value = rng.Value Then
                    rng1.Font.Color = rng.Font.Color
                End If
            Next rng1
        End If
    Next rng
End Sub

Artik

**lar9149** · 03-28-2024, 08:00 PM

Originally Posted by Artik

Below not very effective macro, but in small areas perhaps enough.

Sub AAA()
    Dim rngS As Range
    Dim rngT As Range
    Dim rng As Range
    Dim rng1 As Range

    Set rngS = Range("B37").CurrentRegion

    With rngS
        Set rngS = .Offset(1).Resize(.Rows.Count - 1)
    End With

    Set rngT = Range("B7").CurrentRegion

    For Each rng In rngS
        If rng.Font.ColorIndex <> xlAutomatic Then
            For Each rng1 In rngT
                If rng1.Value = rng.Value Then
                    rng1.Font.Color = rng.Font.Color
                End If
            Next rng1
        End If
    Next rng
End Sub

Artik

Is there a way to make it adaptable..for example, I included a sample 2 (stock comparison 2 in original post) where the tables are moved down (no longer between B7-B37) and using the header on the bottom table of t15 at the end (P44).

Is there a way to make the macro use the current selection (selected header) and match to the 3 tables above it as in the samples

Note: the tables will always be in the same relative position in reference to each other.

**Artik** · 03-29-2024, 07:27 AM

Assumptions for the operation of the following macro:
1. between the last and penultimate table there is an empty row (in the example "Stock comparison 2", row 43 is empty).
2. between the first three tables, the rows are not empty (cells C22 and C32 contain the value "lm" and there are formulas in rows 23 and 33)

Color the fonts in the selected column in the last table and select the cell with the header. Run the macro.

Sub BBB()
    Dim rngS As Range
    Dim rngT As Range
    Dim rng As Range
    Dim rng1 As Range

    Set rngS = ActiveCell.CurrentRegion

    With rngS
        Set rngS = .Offset(1).Resize(.Rows.Count - 1)
    End With
    
    Set rngS = Intersect(ActiveCell.EntireColumn, rngS)
    
    Set rngT = ActiveCell.End(xlUp).CurrentRegion

    For Each rng In rngS
        If rng.Font.ColorIndex <> xlAutomatic Then
            For Each rng1 In rngT
                If rng1.Value = rng.Value Then
                    rng1.Font.Color = rng.Font.Color
                End If
            Next rng1
        End If
    Next rng
End Sub

The task can, of course, be solved in 100 other ways, analyzing the location and content of the tables in more detail. For now, this is one of the simplest solutions.

Artik

**lar9149** · 03-29-2024, 09:58 AM

Originally Posted by Artik

Assumptions for the operation of the following macro:
1. between the last and penultimate table there is an empty row (in the example "Stock comparison 2", row 43 is empty).
2. between the first three tables, the rows are not empty (cells C22 and C32 contain the value "lm" and there are formulas in rows 23 and 33)

Color the fonts in the selected column in the last table and select the cell with the header. Run the macro.

Sub BBB()
    Dim rngS As Range
    Dim rngT As Range
    Dim rng As Range
    Dim rng1 As Range

    Set rngS = ActiveCell.CurrentRegion

    With rngS
        Set rngS = .Offset(1).Resize(.Rows.Count - 1)
    End With
    
    Set rngS = Intersect(ActiveCell.EntireColumn, rngS)
    
    Set rngT = ActiveCell.End(xlUp).CurrentRegion

    For Each rng In rngS
        If rng.Font.ColorIndex <> xlAutomatic Then
            For Each rng1 In rngT
                If rng1.Value = rng.Value Then
                    rng1.Font.Color = rng.Font.Color
                End If
            Next rng1
        End If
    Next rng
End Sub

The task can, of course, be solved in 100 other ways, analyzing the location and content of the tables in more detail. For now, this is one of the simplest solutions.

Artik

This works beautifully and exactly the way I wanted.

Thank you Artik

If I added 2 tables under the same table as in sample 3 (stock comparison 3) , could this macro be adjusted so that it would compare the 3 tables above it and also 2 tables below doing the same thing. Also it didn't seem to bold the the colors?..can the macro bold the colors too?
And again the relative positions of the tables stay the same

**Artik** · 03-29-2024, 07:45 PM

Follow the same steps as in version #2 before running the macro.

Sub CCC()
    Dim rngS As Range
    Dim rngT As Range
    Dim rng As Range
    Dim rng1 As Range
    Dim lEndTblRow As Long
    Dim lRow As Long
    Dim l1stCol As Long
    Dim lLstCol As Long

    l1stCol = Cells.Find(What:="1 ext", After:=Range("A1"), _
                         LookIn:=xlFormulas2, LookAt:=xlWhole, _
                         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                         MatchCase:=False, SearchFormat:=False).Column

    lLstCol = Cells(ActiveCell.Row, l1stCol).End(xlToRight).Column
    lEndTblRow = Cells(ActiveCell.Row, lLstCol).End(xlDown).Row


    Set rngS = Range(Cells(ActiveCell.Row + 1, ActiveCell.Column), Cells(lEndTblRow, ActiveCell.Column))

    lRow = Cells.SpecialCells(xlCellTypeLastCell).Row

    Set rngT = ActiveCell.End(xlUp).CurrentRegion

    Set rngT = Union(rngT, Intersect(Rows(lEndTblRow + 3).Resize(lRow - lEndTblRow - 2), Columns(l1stCol).Resize(, lLstCol - l1stCol + 1)))

    For Each rng In rngS
        If rng.Font.ColorIndex <> xlAutomatic Then
            For Each rng1 In rngT
                If rng1.Value = rng.Value Then
                    rng1.Font.Color = rng.Font.Color
                    rng1.Font.Bold = True
                End If
            Next rng1
        End If
    Next rng

End Sub

Use this macro to remove formatting from the target tables (also select a cell in the source table header)

Sub RemoveFormat()
    Dim rngT As Range
    Dim lEndTblRow As Long
    Dim lRow As Long
    Dim l1stCol As Long
    Dim lLstCol As Long

    l1stCol = Cells.Find(What:="1 ext", After:=Range("A1"), _
                         LookIn:=xlFormulas2, LookAt:=xlWhole, _
                         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                         MatchCase:=False, SearchFormat:=False).Column

    lLstCol = Cells(ActiveCell.Row, l1stCol).End(xlToRight).Column
    lEndTblRow = Cells(ActiveCell.Row, lLstCol).End(xlDown).Row

    lRow = Cells.SpecialCells(xlCellTypeLastCell).Row

    Set rngT = ActiveCell.End(xlUp).CurrentRegion

    Set rngT = Union(rngT, Intersect(Rows(lEndTblRow + 3).Resize(lRow - lEndTblRow - 2), Columns(l1stCol).Resize(, lLstCol - l1stCol + 1)))

    rngT.Font.ColorIndex = xlAutomatic
    rngT.Font.Bold = False

End Sub

Artik

**lar9149** · 03-29-2024, 08:05 PM

Originally Posted by Artik

Follow the same steps as in version #2 before running the macro.

Sub CCC()
    Dim rngS As Range
    Dim rngT As Range
    Dim rng As Range
    Dim rng1 As Range
    Dim lEndTblRow As Long
    Dim lRow As Long
    Dim l1stCol As Long
    Dim lLstCol As Long

    l1stCol = Cells.Find(What:="1 ext", After:=Range("A1"), _
                         LookIn:=xlFormulas2, LookAt:=xlWhole, _
                         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                         MatchCase:=False, SearchFormat:=False).Column

    lLstCol = Cells(ActiveCell.Row, l1stCol).End(xlToRight).Column
    lEndTblRow = Cells(ActiveCell.Row, lLstCol).End(xlDown).Row


    Set rngS = Range(Cells(ActiveCell.Row + 1, ActiveCell.Column), Cells(lEndTblRow, ActiveCell.Column))

    lRow = Cells.SpecialCells(xlCellTypeLastCell).Row

    Set rngT = ActiveCell.End(xlUp).CurrentRegion

    Set rngT = Union(rngT, Intersect(Rows(lEndTblRow + 3).Resize(lRow - lEndTblRow - 2), Columns(l1stCol).Resize(, lLstCol - l1stCol + 1)))

    For Each rng In rngS
        If rng.Font.ColorIndex <> xlAutomatic Then
            For Each rng1 In rngT
                If rng1.Value = rng.Value Then
                    rng1.Font.Color = rng.Font.Color
                    rng1.Font.Bold = True
                End If
            Next rng1
        End If
    Next rng

End Sub

Use this macro to remove formatting from the target tables (also select a cell in the source table header)

Sub RemoveFormat()
    Dim rngT As Range
    Dim lEndTblRow As Long
    Dim lRow As Long
    Dim l1stCol As Long
    Dim lLstCol As Long

    l1stCol = Cells.Find(What:="1 ext", After:=Range("A1"), _
                         LookIn:=xlFormulas2, LookAt:=xlWhole, _
                         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                         MatchCase:=False, SearchFormat:=False).Column

    lLstCol = Cells(ActiveCell.Row, l1stCol).End(xlToRight).Column
    lEndTblRow = Cells(ActiveCell.Row, lLstCol).End(xlDown).Row

    lRow = Cells.SpecialCells(xlCellTypeLastCell).Row

    Set rngT = ActiveCell.End(xlUp).CurrentRegion

    Set rngT = Union(rngT, Intersect(Rows(lEndTblRow + 3).Resize(lRow - lEndTblRow - 2), Columns(l1stCol).Resize(, lLstCol - l1stCol + 1)))

    rngT.Font.ColorIndex = xlAutomatic
    rngT.Font.Bold = False

End Sub

Artik

Perfect your help is much appreciated. Will mark trend is solved.

Using a macro to find matching numbers within tables

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Using a macro to find matching numbers within tables

Re: Using a macro to find matching numbers within tables

Re: Using a macro to find matching numbers within tables

Re: Using a macro to find matching numbers within tables

Re: Using a macro to find matching numbers within tables

Re: Using a macro to find matching numbers within tables

Re: Using a macro to find matching numbers within tables

Thread Information

Users Browsing this Thread

Similar Threads

Find Value in Qry results Table and return all matching Rows from other Tables

[SOLVED] Find matching dates with numbers and result these .

[SOLVED] Macro to run after matching column dates from two separate excel tables

[SOLVED] Find all matching values in two tables and return identifier

[SOLVED] Find matching header between two tables and returning that column's specific row value.

Find Non Matching Value in rows between two tables

[SOLVED] Find matching words in 10 columns and add row numbers of matching words

Bookmarks

Bookmarks

Posting Permissions