Receiving Error when trying to run macro on multiple sheets using VBA-CodePudding

I have the below macro that should be running on each sheet in my workbook. When I run this code, I am getting the following error: 'A table cannot overlap another table' and it is highlighting this line:

        ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$I"), , xlYes).Name = _
            "Table1"

Is this because I applied the macro to table one and now it cannot be applied to the other tables?

All sheets have the same column headers but different number of rows (not sure if that matters). Essentially all I am trying to do is get rid of the index, format the data into a table, extend the column lengths to fit all the column names, and rename the columns.

Another thing to note, there are about 170 sheets that this macro needs to run through.

Sub forEachWs()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        Call CreateTables(ws)
    Next
End Sub


Sub CreateTables(ws As Worksheet)
'
' CreateTables Macro
'
' Keyboard Shortcut: Ctrl Shift S
'
    With ws
        Columns("A:A").Select
        Selection.Delete Shift:=xlToLeft
        Columns("A:I").Select
        Application.CutCopyMode = False
        ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$I"), , xlYes).Name = _
            "Table1"
        Columns("A:I").Select
        ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight1"
        Columns("A:I").EntireColumn.AutoFit
        Range("Table1[[#Headers],[Tier2_ID]]").Select
        ActiveCell.FormulaR1C1 = "Community ID"
        Range("Table1[[#Headers],[Tier2_Name]]").Select
        ActiveCell.FormulaR1C1 = "Community Name"
        Range("Table1[[#Headers],[Current_MBI]]").Select
        ActiveCell.FormulaR1C1 = "Current MBI"
        Range("Table1[[#Headers],[countMBI]]").Select
        ActiveCell.FormulaR1C1 = "Cout"
        Range("Table1[[#Headers],[Cout]]").Select
        ActiveCell.FormulaR1C1 = "Count"
        Range("Table1[[#Headers],[TotalEDVisits]]").Select
        ActiveCell.FormulaR1C1 = "Total ED Visits"
        Range("Table1[[#Headers],[EDtoIPTotal]]").Select
        ActiveCell.FormulaR1C1 = "Total ED to Inpatient"
        Range("Table1[[#Headers],[totalSev1to3]]").Select
        ActiveCell.FormulaR1C1 = "Severity 1 to 3"
        Range("Table1[[#Headers],[totalSev4to6]]").Select
        ActiveCell.FormulaR1C1 = "Severity 4 to 6"
        Range("Table1[[#Headers],[totalPaid]]").Select
        ActiveCell.FormulaR1C1 = "Total Paid"
        Range("L22").Select
    End With
End Sub

CodePudding user response：

Convert Ranges to Tables

The table names in a workbook have to be unique.
This code (re)names each table sequentially i.e. Table1, Table2, Table3....
This is a one-time operation code, so test it first on a copy of your workbook.
If (when) you're satisfied with the outcome, run it in your original workbook.
Now the code is no longer needed (useless).
If you really need to select the cell L22 on each worksheet, you have to make sure the workbook is active (in the first code use If Not wb Is ActiveWorkbook Then wb.Activate). In the second code, you can then use Application.Goto ws.Range("L22") right before (above) the last 'Else.

Sub ConvertToTables()
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet
    Dim n As Long
    
    For Each ws In wb.Worksheets
        n = n   1 ' to create Table1, Table2, Table3...
        ConvertToTable ws, "Table", n
    Next

End Sub

Sub ConvertToTable( _
        ByVal ws As Worksheet, _
        ByVal TableBaseName As String, _
        ByVal TableIndex As Long)
'
' CreateTables Macro
'
' Keyboard Shortcut: Ctrl Shift S
'
    
    ' Note that all column names have to be unique i.e. you cannot
    ' rename the 'countMBI' column to 'Cout' before the existing 'Cout' column
    ' has been renamed.
    
    Const OldColsList As String _
        = "Tier2_ID,Tier2_Name,Current_MBI,Cout," _
        & "countMBI,TotalEDVisits,EDtoIPTotal,totalSev1to3," _
        & "totalSev4to6,totalPaid"
    Const NewColsList As String _
        = "Community ID,Community Name,Current MBI,Count," _
        & "Cout,Total ED Visits,Total ED to Inpatient,Severity 1 to 3," _
        & "Severity 4 to 6,Total Paid"
    Const FirstCellAddress As String = "A1"
    
    ' Reference the first cell ('fCell').
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    
    ' Check if the first cell is part of a table ('tbl').
    ' A weak check whether the table has already been created.
    Dim tbl As ListObject: Set tbl = fCell.ListObject
    
    If tbl Is Nothing Then ' the first cell is not part of a table
    
        ' Reference the range ('rg').
        Dim rg As Range: Set rg = fCell.CurrentRegion
        ' Delete the first column. Note that the range has shrinked by a column.
        rg.Columns(1).Delete xlShiftToLeft
         
        ' Convert the range to a table ('tbl').
        Set tbl = ws.ListObjects.Add(xlSrcRange, rg, , xlYes)
        
        With tbl
            
            .Name = TableBaseName & CStr(TableIndex)
            .TableStyle = "TableStyleLight1"
            
            ' Write the lists to string arrays ('OldCols', 'NewCols')
            Dim OldCols() As String: OldCols = Split(OldColsList, ",")
            Dim NewCols() As String: NewCols = Split(NewColsList, ",")
            
            Dim lc As ListColumn
            Dim n As Long
            
            ' Loop through the elements of the arrays...
            For n = 0 To UBound(OldCols)
                ' Attempt to reference a table column by its old name.
                On Error Resume Next
                    Set lc = .ListColumns(OldCols(n))
                On Error GoTo 0
                ' Check if the column reference has been created.
                If Not lc Is Nothing Then ' the column exists
                    lc.Name = NewCols(n) ' rename the column
                    Set lc = Nothing ' reset to reuse in the next iteration
                'Else ' the column doesn't exist; do nothing
                End If
            Next n
                
            ' The columns should be autofitted after their renaming.
            .Range.EntireColumn.AutoFit
                
        End With
         
    'Else ' the first cell is part of a table; do nothing
    End If
    
End Sub