CODEWITHSUNDEEP
vbaexcel
Weloo
Weloo

Reputation: 625

A Static table with dynamic columns in every worksheet in the original workbook! error: a table cannot overlap another table

I have a bunch of results Excel files in a folder and 14 different keys which i have to:

  1. Create a worksheet with the name of each key of them!
  2. Create a static table in each worksheet.
  3. Loop through the results folder and open every result workbook.
  4. Add a column to the table in the worksheet named for this key.
  5. Name this column with the name of the result workbook i just opened.
  6. Retrieve the data according to the key and paste them to the table with the new column.
  7. Close the opened workbook and go for the next one!

I worked in the code but as mentioned in the title, i get a runtime error in this line: ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlNo).Name = "Table6"

every time i run this code and it creates only one table in the active sheet not in all the original workbook ('task') sheets and adds a messed up column to the table without the required header!

    Option Explicit

    Public tbl As ListObject

    Sub createTable()                           'v1a

Dim DS As Worksheet
Dim oTbl As ListObject

[C13].Cut Destination:=[E16]                'move cell [C13] to cell [E16]

' **********************************************
'a loop to clear all the workbook and make sure it runs only once
' **********************************************
For Each DS In ThisWorkbook.Worksheets
 With DS
 .Activate
  On Error Resume Next
  For Each oTbl In DS.ListObjects
        If oTbl.Name = "Table6" Then
            ActiveSheet.ListObjects("Table6").Delete
        End If
      Next oTbl
 End With
Next DS
'**********************************************

[$B$13:$D$18].Select                        'select range for Table..
ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlNo).Name = "Table6"
Set tbl = ActiveSheet.ListObjects("Table6") 'assign shortcut

[B13] = "BW"                                'enter table heading in cell
[C13] = "Spec"                              'enter table heading in cell
[D13] = "dBc"                               'enter table heading in cell

[B13:D13].HorizontalAlignment = xlCenter    'apply alignment to cells
[B13:D13].BorderAround Weight:=xlMedium     'draw outer border around range

[14:19].RowHeight = 30                      'set row height for range

[B14] = "1.4MHz"                            'enter BandWidth text in cell
[B15] = "3MHz"                              'enter BandWidth text in cell
[B16] = "5MHz"                              'enter BandWidth text in cell
[B17] = "10MHz"                             'enter BandWidth text in cell
[B18] = "15MHz"                             'enter BandWidth text in cell
[B19] = "20MHz"                             'enter BandWidth text in cell

[B14:B19].HorizontalAlignment = xlCenter    'apply alignment to cells

[B14:B19].BorderAround Weight:=xlMedium     'draw outer border around range
[C14:C19].BorderAround Weight:=xlMedium     'draw outer border around range
[D14:D19].BorderAround Weight:=xlMedium     'draw outer border around range

[G11] = ""                                  'clear cell

ActiveWindow.ScrollColumn = 1               'scroll to column [A]
ActiveWindow.ScrollRow = 2                  'scroll to row 2

[D1].Select                                 'put cellpointer in tidy location

End Sub



    Sub LoopAllExcelFilesInFolder()

    Dim wbk As Workbook
    Dim WS As Worksheet
    Dim Filename As String
    Dim Path As String
    Dim saywhat
    Dim zItem
    Dim arr_Spec(14) As String
    Dim element As Variant
    Dim shtname_loop As Variant
    Dim LastRow As Long
    Dim dBc As Long
    Dim WC As Long
    Dim Spec As String
    Dim BW_static As Long
    Dim BW As Long
    Dim Margin As Long
    Dim RowCount As Integer
    Dim r As Long
    Dim lngStart As String
    Dim lngEnd As String
    Dim BW_Name As String
    Dim BW_row As Integer
    Dim col_num As Integer
    Dim flag As Boolean


    'Spec keys values..
    arr_Spec(0) = "aclr_utra1"
    arr_Spec(1) = "aclr_utra2"
    arr_Spec(2) = "aclr_eutra"
    arr_Spec(3) = "evm_qpsk"
    arr_Spec(4) = "Pout_max_qpsk"
    arr_Spec(5) = "freq_error"
    arr_Spec(6) = "SEM0-1"
    arr_Spec(7) = "SEM1-2.5"
    arr_Spec(8) = "SEM2.8-5"
    arr_Spec(9) = "SEM5-6"
    arr_Spec(10) = "SEM6-10"
    arr_Spec(11) = "SEM10-15"
    arr_Spec(12) = "SEM15-20"
    arr_Spec(13) = "SEM20-25"


    Path = ThisWorkbook.Path       'set a default path

    ' **********************************************
    'a loop to create a table in each sheet
    ' **********************************************
    For Each WS In ThisWorkbook.Worksheets
    With WS
     Call createTable
    End With
    Next WS
    '**********************************************
    'DISPLAY FOLDER SELECTION BOX.. 'display folder picker
    '**********************************************
    With Application.FileDialog(msoFileDialogFolderPicker) 'use shortcut
    saywhat = "Select the source folder for the source datafiles.." 'define browser text
    .Title = saywhat               'show heading message for THIS dialog box
    .AllowMultiSelect = False      'allow only one file to be selected
    .InitialFileName = Path        'set default source folder
    zItem = .Show                  'display the file selection dialog

    .InitialFileName = ""          'clear and reset search folder\file filter

    If zItem = 0 Then Exit Sub     'User cancelled; 0=no folder chosen

    Path = .SelectedItems(1)       'selected folder
    End With                       'end of shortcut
    '**********************************************

    If Right(Path, 1) <> "\" Then  'check for required last \ in path
    Path = Path & "\"              'add required last \ if missing
    End If                         'end of test fro required last \ char

    Debug.Print Path

    Filename = Dir(Path & "*.xlsm")
    Debug.Print Filename

    col_num = 5
    flag = True

    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Do While Len(Filename) > 0
    Set wbk = Workbooks.Open(Path & Filename, ReadOnly:=True)   'define shortcut
    wbk.Activate                                'switch to data file
    'find BW number starting and ending positions
    'which will be between the "_" and "_" in the file name it's like Report_B1_2.xslm
    lngStart = Application.WorksheetFunction.Find("_", ThisWorkbook.Name, 1)
    lngEnd = Application.WorksheetFunction.Find("_", ThisWorkbook.Name, 1)
    'pull BW out of the file name
    BW_Name = Mid(ThisWorkbook.Name, lngStart + 1, lngEnd - lngStart - 1)

    Debug.Print lngStart
    Debug.Print lngEnd
    Debug.Print BW_Name

    Sheets(1).Select                            'switch to first worksheet;

    Dim i As Integer
    LastRow = Cells(Rows.Count, "J").End(xlUp).Row  'last data row; use col[J]

    'loop keysstart to stop
    'create a loop on every Spec for every worksheet in the original workbook
    For Each element In arr_Spec                'check for each bandwidth..
    For i = 35 To LastRow                       'process each data row..
    BW = Cells(i, "G")                          'fetch Bandwidth value from [col [G]
    Spec = Cells(i, "I")                        'fetch carrier type from col [I]

    If Spec = CStr(element) Then
        WC = Cells(i, "L")                  'col [L]=WC
        Margin = Cells(i, "M")               'col [M]=Margin

        Windows("Task.xlsm").Activate
        Worksheets(element).Select

        If flag = True Then 'make sure to add the column only once
           ActiveSheet.tbl.ListColumns.Add(col_num).Name = BW_Name ' add new column for the new Band workbook
           flag = False
        End If

        Select Case BW     'Adjacent Channel Leakage-power Ratio, carrier types
        'case key(iFKey)
        Case Is = 1400000
        BW_row = 14

        Case Is = 3000000
        BW_row = 15

        Case Is = 5000000
        BW_row = 16

        Case Is = 10000000
        BW_row = 17

        Case Is = 15000000
        BW_row = 18

        Case Is = 20000000
        BW_row = 19

        Cells(BW_row, "C") = Spec
        Cells(BW_row, "D") = WorksheetFunction.RoundDown((WC - Margin), 5) 'calculating dBc
        Cells(BW_row, col_num) = Margin

        ActiveWorkbook.Save

        wbk.Activate                                'switch back to data file

        Case Else
        'do nothing
        End Select

    End If

    Next i
    Next element

    wbk.Close True
    Filename = Dir                              'get next data file from folder
    col_num = col_num + 1 'increment the column number for the new band workbook
    flag = True           'turn the flag on to let it add new column
    Loop
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    ResetSettings:
    'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    End Sub

and this is the original createTable macro:

    Sub createTable()
    '
    ' createTable Macro
    '

    '
    Range("C13").Select
    Selection.Cut Destination:=Range("E16")
    Range("B1318").Select
    Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Range("$B$13:$D$18"), , xlNo).Name = _
    "Table6"
    Range("Table6[[#Headers],[Column1]]").Select
    ActiveCell.FormulaR1C1 = "BW"
    Range("Table6[[#Headers],[Column2]]").Select
    ActiveCell.FormulaR1C1 = "Spec"
    Range("Table6[[#Headers],[Column3]]").Select
    ActiveCell.FormulaR1C1 = "dBc"
    Range("Table6[[#Headers],[dBc]]").Select
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
    Range("Table6[[#Headers],[Spec]]").Select
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
    Range("A17").Select
    Rows("14:14").RowHeight = 30
    Rows("15:15").RowHeight = 31.5
    Rows("16:16").RowHeight = 29.25
    Rows("17:17").RowHeight = 30
    Rows("18:18").RowHeight = 30.75
    Range("B14").Select
    ActiveCell.FormulaR1C1 = "1.4MHz"
    Range("B15").Select
    ActiveCell.FormulaR1C1 = "3MHz"
    Range("B16").Select
    ActiveCell.FormulaR1C1 = "5MHz"
    Range("B17").Select
    ActiveCell.FormulaR1C1 = "10MHz"
    Range("B18").Select
    ActiveCell.FormulaR1C1 = "15MHz"
    Range("B19").Select
    Rows("19:19").RowHeight = 30
    Range("B19").Select
    ActiveCell.FormulaR1C1 = "20MHz"
    Range("B18").Select
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
    Range("B19").Select
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
    Range("Table6[BW]").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("Table6[Spec]").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("D1").Select
    ActiveWindow.ScrollRow = 2
    Range("Table6[dBc]").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("G11").Select
    ActiveCell.FormulaR1C1 = ""
    Range("E25").Select
    ActiveWindow.Close
    Range("D17").Select
    ActiveCell.FormulaR1C1 = ""
    Range("D15").Select
    End Sub

Upvotes: 0

Views: 403

Answers (1)

YowE3K
YowE3K

Reputation: 23994

Everything in createTable is unqualified (or qualified by ActiveSheet) as to which sheet is being referred to, therefore it is performed on whatever sheet is currently active.

In LoopAllExcelFilesInFolder you have a loop to call the createTable subroutine once for each worksheet in the macro workbook, but without ever activating those worksheets.

For Each WS In ThisWorkbook.Worksheets
With WS
 Call createTable
End With
Next WS

(Note: The With WS block is not being used in that code - at no point are you making use of the ability to use the shortcut of . instead of typing WS.)

The quick and nasty solution to your problem is probably to make each sheet active prior to calling createTable:

For Each WS In ThisWorkbook.Worksheets
    With WS
        .Activate
        createTable
    End With
Next WS

A better approach would be to rewrite createTable to correctly specify which worksheet is being referred to, and possibly passing that worksheet reference as a parameter to the subroutine.

E.g.:

Sub createTable(sht As Worksheet)
    With sht

        .Range("C13").Cut Destination:=.Range("E16")      'move cell [C13] to cell [E16]
        '... etc, etc, etc
    End With
End Sub

and called using

For Each WS In ThisWorkbook.Worksheets
    createTable WS
Next WS

To get around the problem of the code crashing if you have saved the workbook with tables already created, just delete the table before creating it again:

Sub createTable()
    [C13].Cut Destination:=[E16]                'move cell [C13] to cell [E16]

    On Error Resume Next
    ActiveSheet.ListObjects("Table6").Delete
    On Error GoTo 0

    [$B$13:$D$18].Select                        'select range for Table..
    ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlNo).Name = "Table6"
    '... etc

Upvotes: 1

Related Questions