我在一个文件夹中有一堆结果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
答案 0 :(得分：1)
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以正确指定要引用的工作表，并可能将该工作表引用作为参数传递给子例程。
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
并使用
进行调用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