excel - 宏创建文件夹中不同文件中所有不同选项卡的列表

Question

我正在尝试让 VBA 创建不同投资组合中所有不同选项卡的列表。输出应该是一个表格，其列作为选项卡的名称，文件目录位于顶部。我尝试选择一个包含所有不同文件的文件夹(宏文件所在的位置)，但是，我只让宏循环遍历文件夹中的 excel 而什么都不做。

    Dim MyFolder As String 'Path collected from the folder picker dialog
    Dim MyFile As String 'Filename obtained by DIR function
    Dim wbkMacro As Workbook 'The current file that the macro is in
    Dim wbk As Workbook 'Used to loop through each workbook
    
    Set wbkMacro = ActiveWorkbook
    
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
   If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
      Exit Sub
   End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
   'Opens the file and assigns to the wbk variable for future use
   
   Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
   'Replace the line below with the statements you would want your macro to perform
   

   ' Dim mainworkBook As Workbook

    'Set mainworkBook = ActiveWorkbook

    For i = 1 To wbk.Sheets.Count

    'Either we can put all names in an array , here we are printing all the names in Sheet 2

    wbkMacro.Sheets("Sheet1").Range(“A” & i) = wbk.Sheets(i).Name

    Next i
   
   
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub```

Answer 1

列出工作表名称

Option Explicit

Sub ListSheets()
    Const ProcName As String = "ListSheets"
    Dim IsSuccess As Boolean
    On Error GoTo ClearError

    Const dName As String = "Sheet1"
    Const dfcAddress As String = "A1"
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
    Dim dFileName As String: dFileName = dwb.Name
    Dim dCell As Range: Set dCell = dws.Range(dfcAddress)
    
    Dim sFolderPath As String: sFolderPath = dwb.Path & "\"
    Dim sFileName As String: sFileName = Dir(sFolderPath & "*.xls*")
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim swb As Workbook
    Dim ssh As Object
    Dim sFilePath As String
    Dim dData As Variant
    Dim drCount As Long
    Dim dr As Long
    
    Do While Len(sFileName) > 0
        If StrComp(sFileName, dFileName, vbTextCompare) <> 0 Then
            sFilePath = sFolderPath & sFileName
            Set swb = Workbooks.Open(sFilePath)
            drCount = swb.Sheets.Count + 1 ' + 1 for header
            ReDim dData(1 To drCount, 1 To 1)
            dData(1, 1) = sFilePath ' sFileName - write header
            dr = 1
            For Each ssh In swb.Sheets
                dr = dr + 1
                dData(dr, 1) = ssh.Name
            Next ssh
            swb.Close SaveChanges:=False ' it was just read from
            dCell.Resize(drCount).Value = dData ' write to destination worksheet
            Set dCell = dCell.Offset(, 1) ' next column
        End If
        
        sFileName = Dir
   Loop
   
   IsSuccess = True
   
SafeExit:
   
    On Error Resume Next
        If Not Application.EnableEvents Then Application.EnableEvents = True
        Application.ScreenUpdating = True
        
        If IsSuccess Then
            MsgBox "List of sheets created.", vbInformation, ProcName
        Else
            MsgBox "Something went wrong.", vbCritical, ProcName
        End If
    On Error GoTo 0
   
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume SafeExit
End Sub