We help IT Professionals succeed at work.

Creating Worksheets based on Filenames

140 Views
Last Modified: 2018-03-27
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

Comment
Watch Question

Omar SoudaniSenior System Engineer
CERTIFIED EXPERT
Commented:
Unlock this solution and get a sample of our free trial.
(No credit card required)
UNLOCK SOLUTION
Bill PrewTest your restores, not your backups...
CERTIFIED EXPERT
Expert of the Year 2019
Top Expert 2016

Commented:
In which case, why post it here now???


ยปbp
Analyst Assistant
CERTIFIED EXPERT
Commented:
Unlock this solution and get a sample of our free trial.
(No credit card required)
UNLOCK SOLUTION
Eitel DagninIT Security Administrator

Author

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.
NorieAnalyst Assistant
CERTIFIED EXPERT

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.:)
Eitel DagninIT Security Administrator

Author

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.
Eitel DagninIT Security Administrator

Author

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
Omar SoudaniSenior System Engineer
CERTIFIED EXPERT

Commented:
Since this question already tagged as solved, some experts will not look into it, I suggest you post a new one addressing the issue.
Eitel DagninIT Security Administrator

Author

Commented:
Thank you Omar, I will do so now. :)

Gain unlimited access to on-demand training courses with an Experts Exchange subscription.

Get Access
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Empower Your Career
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE

Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Unlock the solution to this question.
Thanks for using Experts Exchange.

Please provide your email to receive a sample view!

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.