VBA to Format Multiple Table Ranges in different worksheets

Question

I have list of worksheets, table names, column names and format details in columns B, C, D and E in a worksheet and I want the VBA macro to loop through this list to apply formatting in the respective worksheet's table/name range columns Or All Columns.

please see the below table and the code I have so far.. can someone help with amending the below code to make it work as per my expectation

#	Worksheet Name	Table Name / Range Name	Column Names	Format
1	Philip	Philip_Test3	Commentary, Date, Time Stamp, Region	CustomFormat
2	Edward	Edward_Test8	City, Region, Template Name	CustomFormat
3	Jessica	Jessica_Test2	Date, Time Stamp, Region	CustomFormat1
4	Tony	Tony_Test1	Commentary, Time Stamp, Region, Template Name	CustomFormat
4	Roger	Roger_TestNew	All Columns	CustomFormat1

Option Explicit
Sub FormatMultipleRanges()
  Dim Cell As Range
   Dim nm As Name
    Dim sht As Worksheet
    Set sht = ThisWorkbook.ActiveSheet
  Dim myRange As Range
    Set myRange = sht.Range("D2:D9")
    
    Dim FormatRng As Range
    Set FormatRng = sht.Range("E2:E9")

    For Each sht In Worksheets
        If Not IsError(Application.Match(sht.Name, Range("B2:B9"), 0)) Then
        
        For Each nm In ActiveWorkbook.Names
    If Not IsError(Application.Match(nm.RefersToRange.Parent.Name, Range("C2:C9"), 0)) Then

For Each Cell In myRange
    CustomFormat (myRange)
Next myRange
      '
          
        End If
        
    Next
End Sub

formatting function

public function CustomFormat(rng as excel.range) 

rng.VerticalAlignment = xlTop
rng.WrapText = True    

end function

public function CustomFormat1(rng as excel.range) 

rng.VerticalAlignment = xlCenter
rng.WrapText = True    

end function

Answer 1

Microsoft documentation:

ListColumn.DataBodyRange property (Excel)

StrComp function

Range.CurrentRegion property (Excel)

Option Explicit
Sub FormatMultipleRanges()
    Dim i As Long, aCol, iVertical As Long
    Dim oSht As Worksheet, oTab As ListObject, oRng As Range
    Dim desSht As Worksheet, arrData
    Set oSht = ThisWorkbook.ActiveSheet
    ' Load data into an array
    arrData = oSht.Range("A1").CurrentRegion.Value
    ' Loop through table
    For i = 2 To UBound(arrData)
        ' Get sheet object
        On Error Resume Next
        Set desSht = Worksheets(arrData(i, 2))
        On Error GoTo 0
        If Not desSht Is Nothing Then
            If desSht.ListObjects.Count > 0 Then
                ' Get table (listobject) object
                On Error Resume Next
                Set oTab = desSht.ListObjects(arrData(i, 3))
                On Error GoTo 0
                If Not oTab Is Nothing Then
                    ' Get the VerticalAlignment setting
                    iVertical = 0
                    If StrComp(arrData(i, 5), "CustomFormat", vbTextCompare) = 0 Then
                        iVertical = xlTop
                    ElseIf StrComp(arrData(i, 5), "CustomFormat1", vbTextCompare) = 0 Then
                        iVertical = xlCenter
                    End If
                    If iVertical <> 0 Then
                        ' Format cols
                        For Each aCol In Split(arrData(i, 4), ",")
                            ' If Col aCol exists in oTab
                            On Error Resume Next
                            Set oRng = oTab.ListColumns(Trim(aCol)).DataBodyRange
                            On Error GoTo 0
                            If Not oRng Is Nothing Then
                                oRng.VerticalAlignment = iVertical
                                oRng.WrapText = True
                            End If
                        Next
                    End If
                End If
            End If
        End If
        Set desSht = Nothing
        Set oTab = Nothing
    Next
End Sub

---

Update:

Sub FormatMultipleRanges()
    Dim i As Long, aCol, iVertical As Long
    Dim oSht As Worksheet, oTab As ListObject, oRng As Range
    Dim desSht As Worksheet, arrData
    Set oSht = ThisWorkbook.ActiveSheet
    ' Load data into an array
    arrData = oSht.Range("A1").CurrentRegion.Value
    ' Loop through table
    For i = 2 To UBound(arrData)
        ' Get sheet object
        On Error Resume Next
        Set desSht = Worksheets(arrData(i, 2))
        On Error GoTo 0
        If Not desSht Is Nothing Then
            If desSht.ListObjects.Count > 0 Then
                ' Get table (listobject) object
                On Error Resume Next
                Set oTab = desSht.ListObjects(arrData(i, 3))
                On Error GoTo 0
                If Not oTab Is Nothing Then
                    For Each aCol In Split(arrData(i, 4), ",")
                        ' All columns in oTab
                        If StrComp("All Columns", aCol, vbTextCompare) = 0 Then
                            Set oRng = oTab.DataBodyRange
                        Else
                            ' If Col aCol exists in oTab
                            On Error Resume Next
                            Set oRng = oTab.ListColumns(Trim(aCol)).DataBodyRange
                            On Error GoTo 0
                        End If
                        If Not oRng Is Nothing Then
                            If StrComp(arrData(i, 5), "CustomFormat", vbTextCompare) = 0 Then
                                Call CustomFormat(oRng)
                            ElseIf StrComp(arrData(i, 5), "CustomFormat1", vbTextCompare) = 0 Then
                                Call CustomFormat1(oRng)
                                ' ElseIf ' modify as needed, add more conditions
                            End If
                        End If
                    Next
                End If
            End If
        End If
        Set desSht = Nothing
        Set oTab = Nothing
    Next
End Sub
Public Sub CustomFormat(rng As Excel.Range)
    rng.VerticalAlignment = xlTop
    rng.WrapText = True
End Sub
Public Sub CustomFormat1(rng As Excel.Range)
    rng.VerticalAlignment = xlCenter
    rng.WrapText = True
End Sub

---

Update2:

Sub FormatMultipleRanges2()
    Dim i As Long, aCol, iVertical As Long, j As Long
    Dim oSht As Worksheet, oRng As Range
    Dim desSht As Worksheet, arrData, rngTab As Range, RowCnt As Long
    'Set oSht = ThisWorkbook.ActiveSheet
    Set oSht = ThisWorkbook.Sheets("MasterSheet") ' modify as needed
    ' Load data into an array
    arrData = oSht.Range("A1").CurrentRegion.Value
    ' Loop through table
    For i = 2 To UBound(arrData)
        ' Get sheet object
        On Error Resume Next
        Set desSht = Worksheets(arrData(i, 2))
        On Error GoTo 0
        If Not desSht Is Nothing Then
            On Error Resume Next
            If desSht.ListObjects.Count > 0 Then
                ' Get table (listobject) object
                Set rngTab = desSht.ListObjects(arrData(i, 3)).Range
            End If
            If rngTab Is Nothing Then
                ' Get the named range
                Set rngTab = desSht.Range(arrData(i, 3))
            End If
            On Error GoTo 0
            If Not rngTab Is Nothing Then
                RowCnt = rngTab.Rows.Count
                For Each aCol In Split(arrData(i, 4), ",")
                    ' All columns
                    If StrComp("All Columns", aCol, vbTextCompare) = 0 Then
                        Set oRng = rngTab.Resize(RowCnt - 1).Offset(1)
                    Else
                        For j = 1 To rngTab.Columns.Count
                            If StrComp(aCol, rngTab.Cells(1, j).Value, vbTextCompare) = 0 Then
                                Set oRng = rngTab.Columns(j).Resize(RowCnt - 1).Offset(1)
                            End If
                        Next
                    End If
                    If Not oRng Is Nothing Then
                        If StrComp(arrData(i, 5), "CustomFormat", vbTextCompare) = 0 Then
                            Call CustomFormat(oRng)
                        ElseIf StrComp(arrData(i, 5), "CustomFormat1", vbTextCompare) = 0 Then
                            Call CustomFormat1(oRng)
                            ' ElseIf ' modify as needed, add more conditions
                        End If
                    End If
                Next
            End If
        End If
        Set desSht = Nothing
        Set oTab = Nothing
    Next
End Sub