Question

我正在尝试使用我拥有的文件选择器，然后将每个文件的列和该文件中的每个工作表都放到一个新工作表中。所以A1会有文件名，B1表名，C1和down会有列标题（在我选中的所有文件中都是A1：??）。还有一些文件很大，所以自动计算会自动有用吗？

另请注意，我在开始时有额外的变量但不一定使用。

这是代码，它是一团糟：

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

我有选择器（一个单独的函数），我跳过工作表，因为文件已损坏，但我显然错过了获取标题和工作表名称的部分。有人可以帮忙吗？

更新MATTHEW＆＃39;代码~~~~~~~~~~~~~~~~~~~~

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 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

Answer 1

当您打开工作簿时，它会变为活动状态，因此您需要创建一个对象，该对象将是您要写入的工作表。在某处顶部。

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 Col_Letter(lngCol As Long) As String
    Dim vArr
    vArr = Split(Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)
End Function

列标题为新工作表

1 个答案: