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 

Open in new window

Eitel DagninIT Security AdministratorAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Omar SoudaniSenior System EngineerCommented:
0
Bill PrewCommented:
In which case, why post it here now???


»bp
0
NorieAnalyst Assistant Commented:
Why do you need an array?
Sub test()
Dim strFilename As String, strPath As String

    strPath = "C:\Test\"
    strFilename = Dir(strPath & "\" & "*.xlsx")

    Do Until strFilename = ""
        Sheets.Add.Name = Split(strFilename, ".")(0)
        strFilename = Dir()
    Loop

End Sub

Open in new window

1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Eitel DagninIT Security AdministratorAuthor Commented:
Hi All,

I post to multiple sites at the same time to receive a wider range of help.. As I work through the help I receive I go back to each site and update my posts. You'll notice with my past question that when i receive an answer I provide the answer to my questions and the link for where I got it.

Sometimes it takes a little longer for me to get around to the sites before a reply comes through.

Apologies for any inconvenience.
0
NorieAnalyst Assistant Commented:
Eitel

There's nothing wrong with that really but on each site you post you should inform that you are cross-posting and provide links when you create the original post(s), not when you get a solution.

If you don't do that it's possible people will spend time trying to help you only to find out that you received a solution elsewhere while they were working on the problem.

Some people might not look too kindly on that.:)
0
Eitel DagninIT Security AdministratorAuthor Commented:
Hi All,

I do apologize sincerely, it didn't occur to me to think of it the way Norie explained - I will for future posts advise with a link when I post a question on multiple forums.

@Norie - I appreciate your reply and the code you provided - it also works great!

I found the one answer here:

https://stackoverflow.com/questions/49509661/creating-worksheets-based-on-filenames

Code:

Sub test()
  Dim Filenames As Variant, strFilename As Variant, strPath As String
  Dim i As LongPtr

  strPath = "D:\myPath"
  strFilename = Dir(strPath & "\" & "*.xlsx")
  Do Until strFilename = ""
    Filenames = Filenames & "|" & strFilename
    strFilename = Dir
  Loop

  Filenames = Mid(Filenames, 2)
  Filenames = Split(Filenames, "|")  ' <- all .xlsx filenames in this array

  For i = LBound(Filenames) To UBound(Filenames)
    with Worksheets.Add 
      .name = Left(Filenames(i), Len(Filenames(i)) - 5)
    end with
  Next i

End Sub

Open in new window

And another reply on a different forum with "cleaner" code: (identical to Norie's code)

Link: http://www.tek-tips.com/viewthread.cfm?qid=1785646

Code:

Option Explicit

Sub test()
Dim strFilename As String
Dim strPath As String

strPath = "D:\myPath\"
strFilename = Dir(strPath & "*.xlsx")
Do Until strFilename = ""
    strFilename = Split(strFilename, ".")(0)
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = strFilename
    strFilename = Dir
Loop

End Sub 

Open in new window


All of them work great.

Apologies for any inconvenience.
0
Eitel DagninIT Security AdministratorAuthor Commented:
There are two issues I require assistance with still on the same subject - Error Handling.

1) If the sheet name already exists

2) To exclude certain files in the directory by file name - This isn't such a huge issue, but if it can be done that would be really great

Here is some code for the first problem - but I don't know how to implement it as the parameters are a string:

Function sheetExists(sheetToFind As String) As Boolean
    sheetExists = False
    For Each Sheet In Worksheets
        If sheetToFind = Sheet.Name Then
            sheetExists = True
            Exit Function
        End If
    Next Sheet
End Function

Open in new window


Here is some code for the second problem:

For i = LBound(Filenames) To UBound(Filenames)

        Do While Filenames <> "test.xlsx"

            With x.Worksheets.Add
            .Name = Left(Filenames(i), Len(Filenames(i)) - 5)
        Loop

    End With

    Next i

Open in new window


With either the Do While or If Else Statement, I keep getting the error:

Loop without Do While
or
End If without Block If
or
Else Without If

I have asked for help on this same topic at the below two links:

http://www.tek-tips.com/viewthread.cfm?qid=1785646
https://stackoverflow.com/questions/49509661/creating-worksheets-based-on-filenames
0
Omar SoudaniSenior System EngineerCommented:
Since this question already tagged as solved, some experts will not look into it, I suggest you post a new one addressing the issue.
0
Eitel DagninIT Security AdministratorAuthor Commented:
Thank you Omar, I will do so now. :)
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.