Macro creating the list of all the different tabs in different files in a folder

Question

I am trying to get VBA to create a list of all the different tabs in different portfolios. The output should be a table with columns as names of tabs and the file dir at the top. I try selecting a folder with all the different files (where also the macro file lies), however, I only get the macro to loop through excels in the folder and does nothing.

    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

List Sheet Names

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