Creating Worksheets based on Filenames

Hi All,

I am trying to create multiple sheets in a single workbook from the file names of all the files in a particular folder.

Example:

1) A folder has 4 .xlsx files and their names are: MyFile1, MyFile2, MyFile3, MyFile4
2) There's a workbook that has only its default sheet inside
3) The macro needs to scan the folder for all the files with .xlsx extension in this folder and store the file names in an array
4) In this example, there are only four files therefore the array should store 4 file names
5) Then the macro will create the four sheets and name each sheet according the file names found in the folder

I currently have the below code sample, which works but there's two issues:

1) It only creates ONE sheet and renames it with the first file's name - The loop is therefore not working here
2) It creates the sheets name with the file name AND the extension (MyFile1.xlsx etc)- I only require the file name, not the extension

Sub CreateNewWorkSheet()

    'Instantiate variables
    Dim xSht As Worksheet
    Dim xNSht As Worksheet
    Dim xSUpdate As Boolean
    Dim xRow As Long
    Dim MyFile As String
    Dim Counter As Long
        
    On Error Resume Next
    
    Set xSht = ActiveWorkbook.Sheets("3rd Party")
    
    'Create a dynamic array variable, and then declare its initial size
    Dim DirectoryListArray() As String
    ReDim DirectoryListArray(1000)

    'Loop through all the files in the directory by using Dir$ function
    MyFile = Dir$("C:\Users\Desktop\3rd Party\Work Folder\*.*")
    
    'This line of code just helps the macro sun faster
    xSUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    
    For Counter = 0 To UBound(DirectoryListArray)
    
        DirectoryListArray(Counter) = MyFile
    
        'If the sheet does not exist, then create the new sheet and name it the string from index I
        If xNSht Is Nothing Then
            Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
            xNSht.Name = DirectoryListArray(Counter)
        Else
            
        End If
        
        Counter = Counter + 1
    
    Next Counter

    'Reset the size of the array without losing its values by using Redim Preserve
    ReDim Preserve DirectoryListArray(Counter - 1)
    
    xSht.AutoFilterMode = False
    xSht.Activate
    Application.ScreenUpdating = xSUpdate
    
End Sub 

Select allOpen in new window