原始工作簿中的每个工作表中的dynamic列的静态表！ 错误：一个表不能重叠另一个表

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

1. 用他们每个键的名字创build一个工作表！
2. 在每个工作表中创build一个静态表。
3. 循环浏览结果文件夹并打开每个结果工作簿。
4. 在为该键命名的工作表中的表中添加一列。
5. 用刚刚打开的结果工作簿的名称命名该列。
6. 根据键检索数据并将其粘贴到新列的表中。
7. closures打开的工作簿，并进入下一个！

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

每次我运行这个代码，它只在活动工作表中创build一个表，而不是在所有的原始工作簿（'任务'）工作表中，并添加一个混乱的列到表没有所需的标题！

  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 

Answer 1

createTable都是不合格的（或由ActiveSheet限定），因此在任何表单当前处于活动状态时都会执行该表单。

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

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

（注意：在这个代码中没有使用With WS块 – 在任何时候你都不能使用快捷键的function，而不是inputWS. ）

---

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

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

---

更好的方法是重写createTable来正确指定哪个工作表被引用，并且可能将该工作表引用作为parameter passing给子例程。

例如：

 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 

---

若要解决代码崩溃的问题（如果已经使用已经创build的表保存了工作簿），只需在删除表之前再次创build该表即可：

 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