列标题到新工作表
我正在尝试使用文件选取器，然后将每个文件和该文件中的每个表的列都放到一个新表中。 所以A1会有文件名，B1表格名称，C1和下来将有列标题（这是所有文件林拾取A1：??）。 还有一些文件很大，所以自动计算自动有帮助？
另外请注意，我在开始时有额外的variables，但不一定使用。
这是代码，它是一个混乱：
Sub ColumnHeaders() 'includes filling down 'Skips unreadable files Dim wb As Workbook, fileNames As Object, errCheck As Boolean Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet Dim y As Range, intRow As Long, i As Integer Dim r As Range, lr As Long, myrg As Range, z As Range Dim boolWritten As Boolean, lngNextRow As Long Dim intColNode As Integer, intColScenario As Integer Dim intColNext As Integer, lngStartRow As Long Dim lngLastNode As Long, lngLastScen As Long 'Skipped worksheet for file names Dim wksSkipped As Worksheet Set wksSkipped = ThisWorkbook.Worksheets("Skipped") ' Turn off screen updating and automatic calculation With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With ' Create a new worksheet, if required On Error Resume Next Set wksSummary = ActiveWorkbook.Worksheets("Headers") On Error GoTo 0 If wksSummary Is Nothing Then Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)) wksSummary.Name = "headers" End If ' Set the initial output range, and assign column headers With wksSummary Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0) Set r = y.Offset(0, 1) Set z = y.Offset(0, -2) lngStartRow = y.Row .Range("A1:C1").Value = Array("File Name", "Sheet Name", "headers") End With 'get user input for files to search Set fileNames = CreateObject("Scripting.Dictionary") errCheck = UserInput.FileDialogDictionary(fileNames) If errCheck Then Exit Sub End If ''' For Each Key In fileNames 'loop through the dictionary On Error Resume Next Set wb = Workbooks.Open(fileNames(Key)) If Err.Number <> 0 Then Set wb = Nothing ' or set a boolean error flag End If On Error GoTo 0 ' or your custom error handler If wb Is Nothing Then wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key) Else Debug.Print "Successfully loaded " & fileNames(Key) wb.Application.Visible = False 'make it not visible ' more working with wb 代码应该在这里
wb.Close savechanges:=False 'close the workbook do not save Set wb = Nothing 'release the object End If Next 'End of the fileNames loop Set fileNames = Nothing ' Autofit column widths of the report wksSummary.Range("A1:C1").EntireColumn.AutoFit ' Reset system settings With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .Visible = True End With End Sub
我有select器（一个单独的function），我跳过工作表incase该文件已损坏，但我显然是缺less的地方获得标题和工作表名称。 谁能帮忙？
更新与马修的代码~~~~~~~~~~~~~~~~~~~~
Sub ColumnHeaders() 'includes filling down 'Skips unreadable files Dim wb As Workbook, fileNames As Object, errCheck As Boolean Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet Dim y As range, intRow As Long, i As Integer Dim r As range, lr As Long, myrg As range, z As range Dim boolWritten As Boolean, lngNextRow As Long Dim intColNode As Integer, intColScenario As Integer Dim intColNext As Integer, lngStartRow As Long Dim lngLastNode As Long, lngLastScen As Long 'need addition Dim wsReport As Excel.Worksheet Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to 'Skipped worksheet for file names Dim wksSkipped As Worksheet Set wksSkipped = ThisWorkbook.Worksheets("Skipped") ' Turn off screen updating and automatic calculation With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With ' Create a new worksheet, if required On Error Resume Next Set wksSummary = ActiveWorkbook.Worksheets("Headers") On Error GoTo 0 If wksSummary Is Nothing Then Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)) wksSummary.Name = "headers" End If ' Set the initial output range, and assign column headers With wksSummary Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0) Set r = y.Offset(0, 1) Set z = y.Offset(0, -2) lngStartRow = y.Row .range("A1:C1").Value = Array("File Name", "Sheet Name", "headers") End With 'get user input for files to search Set fileNames = CreateObject("Scripting.Dictionary") errCheck = UserInput.FileDialogDictionary(fileNames) If errCheck Then Exit Sub End If ''' For Each Key In fileNames 'loop through the dictionary On Error Resume Next Set wb = Workbooks.Open(fileNames(Key)) If Err.Number <> 0 Then Set wb = Nothing ' or set a boolean error flag End If On Error GoTo 0 ' or your custom error handler If wb Is Nothing Then wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key) Else Debug.Print "Successfully loaded " & fileNames(Key) wb.Application.Visible = False 'make it not visible ' more working with wb 'New addition Dim iIndex As Integer Dim lCol As Long Dim lRow As Long lRow = 1 'Loop through the worksheets in the current workbook. For iIndex = 1 To wb.Worksheets.Count 'Set the current worksheet Set ws = Application.Worksheets(iIndex) 'List out the workbook and worksheet names wsReport.range("A" & lRow).Value = wb.Name wsReport.range("B" & lRow).Value = ws.Name 'Start a counter of the columns that we are writing to lOutputCol = 3 'Loop through the columns. For lCol = 1 To ws.UsedRange.Columns.Count 'Write the header wsReport.range(Col_Letter(lOutputCol) & lRow).Value = ws.range(Col_Letter(lCol) & "1").Value 'Increment our column counters. lOutputCol = lOutputCol + 1 lCol = lCol + 1 Next lCol 'Increment the row we are writing to lRow = lRow + 1 Next iIndex wb.Close savechanges:=False 'close the workbook do not save Set wb = Nothing 'release the object End If Next 'End of the fileNames loop Set fileNames = Nothing ' Autofit column widths of the report wksSummary.range("A1:C1").EntireColumn.AutoFit ' Reset system settings With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .Visible = True End With End Sub
两个function：
Function Col_Letter(lngCol As Long) As String Dim vArr vArr = Split(Cells(1, lngCol).Address(True, False), "$") Col_Letter = vArr(0) End Function
和
Function FileDialogDictionary(ByRef file As Object) As Boolean ' returns true if the user cancels 'Declare a variable as a FileDialog object. Dim fd As FileDialog Dim item As Variant Dim i As Long 'Create a FileDialog object as a File Picker dialog box. file.RemoveAll 'clear the dictionary Set fd = Application.FileDialog(msoFileDialogFilePicker) 'Declare a variable to contain the path 'of each selected item. Even though the path is a String, 'the variable must be a Variant because For Each...Next 'routines only work with Variants and Objects. 'Use a With...End With block to reference the FileDialog object. With fd 'Use the Show method to display the File Picker dialog box and return the user's action. 'The user pressed the action button. .Title = "Select Excel Workbooks" 'Change this to suit your purpose .AllowMultiSelect = True .Filters.Clear .Filters.Add "Microsoft Excel files", "*.xlsx,*.xls" If .Show = -1 Then 'Step through each string in the FileDialogSelectedItems collection. For Each item In .SelectedItems 'loop through all selected and add to dictionary i = i + 1 file.Add i, item Next item FileDialogDictionary = False 'The user pressed Cancel. Else FileDialogDictionary = True Set fd = Nothing Exit Function End If End With Set fd = Nothing 'Set the object variable to Nothing. End Function
当您打开工作簿时，它将变为活动状态，因此您需要创build一个对象，该对象将成为您正在写入的工作表。 在顶部的某处。
Dim wsReport As Excel.Worksheet Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
代码写出数据。 插入你的位置“代码应该在这里”
Dim iIndex As Integer Dim lCol As Long Dim lRow As Long Dim lOutputCol As Long lRow = 1 'Loop through the worksheets in the current workbook. For iIndex = 1 To wb.Worksheets.count 'Set the current worksheet Set ws = Application.Worksheets(iIndex) 'List out the workbook and worksheet names wsReport.Range("A" & lRow).Value = wb.name wsReport.Range("B" & lRow).Value = ws.name 'Start a counter of the columns that we are writing to lOutputCol = 3 'Loop through the columns. For lCol = 1 To ws.UsedRange.Columns.count 'Write the header wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value 'Increment our column counters. lOutputCol = lOutputCol + 1 Next lCol 'Increment the row we are writing to lRow = lRow + 1 Next iIndex
你需要添加这个function
Function Col_Letter(lngCol As Long) As String Dim vArr vArr = Split(Cells(1, lngCol).Address(True, False), "$") Col_Letter = vArr(0) End Function