原始工作簿中每个工作表中带有动态列的静态表！错误：一张表不能与另一张表重叠

debugcn 发表于 Dev

韦洛

我在一个文件夹中有一堆结果 Excel 文件和 14 个不同的键，我必须：

创建一个工作表，其中包含每个键的名称！
在每个工作表中创建一个静态表。
循环遍历结果文件夹并打开每个结果工作簿。
在以此键命名的工作表中的表中添加一列。
使用我刚刚打开的结果工作簿的名称命名此列。
根据键检索数据并将它们粘贴到具有新列的表中。
关闭打开的工作簿并进行下一个！

我在代码中工作，但如标题中所述，我在这一行收到运行时错误： ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlNo).Name = "Table6"

每次我运行这段代码时，它只在活动工作表中创建一个表格，而不是在所有原始工作簿（“任务”）工作表中，并在没有所需标题的情况下向表格中添加了一个混乱的列！

    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

YoE3K

中的所有createTable内容都未限定（或由限定ActiveSheet）关于引用哪个工作表，因此它在当前处于活动状态的任何工作表上执行。

在LoopAllExcelFilesInFolder您有一个循环为createTable宏工作簿中的每个工作表调用一次子例程，但从未激活这些工作表。

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

（注意：该With WS代码块未在该代码中使用 - 您在任何时候都没有利用使用快捷方式.而不是键入的功能WS.）

解决您的问题的快速而讨厌的解决方案可能是在调用之前使每个工作表处于活动状态createTable：

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

更好的方法是重写createTable以正确指定正在引用哪个工作表，并可能将该工作表引用作为参数传递给子例程。

例如：

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

并调用使用

For Each WS In ThisWorkbook.Worksheets
    createTable WS
Next WS

如果您保存了包含已创建表的工作簿，要解决代码崩溃的问题，只需在再次创建表之前删除该表：

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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。