create sheets based on extensions files and copy to each months

[abdelfattah]

hello
I hope finding in this forum what I 'm looking for despite what I'm asking it not easy I need some experts to achieve my project
my known in vba is not advanced but I can deal with codes and amending some details to what I need but writing the code absolutely I can't ,so what I want create sheets based on names in folders my directory is "D:\files" and the folder file contains many many subfolders names XLSM,XLS, XLSX,PDF,DOC,PPT,MP4,AVI ,TEXT....etc and increasable and each sub folders contain the files
after create the sheets it brings all the files from subfolders to the sheet name based on contain from extension file for instance the files pdf should copy to sheet pdf and copy the files to specific month if I issue files in JAN then copy to COL JAN for all files from all subfolders and so on the rests of months
by the way I also issued in this forum
https://www.excelforum.com/excel-programming-vba-macros/1344094-create-sheets-based-on-extensions-files-and-copy-to-each-months.html

[Kenneth Hobs]

Insufficient details is the reason you have no solutions I suspect. Otherwise, we have to make guesses about your needs which could be wrong.

1. Would all of the file extension subfolder named worksheet tabs already exist? e.g. XLS exists but not XLSX, XLSM, etc.
a. If not exists, create worksheet in the macro?

2. The column headings are 3 letter month name abbreviations. What do the values in that column mean?
a. My guess is the base filename? e.g. INV1000 for JAN column cell B2 based on d:\files\PDF\INV1000.pdf

3. The months are based on the file's date creation or modification date or?

[abdelfattah]

Hi, Kenneth
about question 1 XLSX, XLSM, etc.
a. If not exists, doesn't create worksheet in the macro just what are existed should create and if I create anew subfolder to a new extension file then create it when run macro again the macro , it should be flexible
about question2
it means files name in subfolders are created for all months so when issues files in JAN MONTH then brings all files from subfolders to COL JAN and the same thing with rests of months
about question 3 it's an important point they are both creation and modification

[Kenneth Hobs]

Creation and modification dates mean two different things. I only coded for creation date but it is easily changed to modification date. Be aware though that you should probably delete the data range each time if you use modification dates as it will list a file in more than one column, unless you want that.

1. Put code below in a Module in your xlsm file with the worksheets setup.
2. Change the value pf to be your parent folder's path.
3. Set the fso reference as commented.
4. Run Main().


Sub Main()
Dim pf As String, sfs, sfp
'Tools > References > Microsoft Scripting Runtime
Dim fso As FileSystemObject, sf As Scripting.Folder, f As Scripting.File
Dim ws As Worksheet, fr As Range
Dim mn As String, fbn As String

'Parent Folder
pf = "d:\myfiles\t"

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Set fso = New FileSystemObject

'Array with Subfolder paths.
'http://www.vbaexpress.com/forum/showthread.php?58579-get-file-paths-based-on-name-criteria-from-folder
sfs = aFFs(pf, "/ad", True)

'No error check for subfolder paths put into sfs. At least one subfolder is assumed.
For Each sfp In sfs
Set sf = fso.GetFolder(sfp)
'Set worksheet for input: Assumes that each subfolder name has a worksheet name.
Set ws = Worksheets(sf.ShortName) 'e.g. CSV, XLS, XLSM, etc.
For Each f In sf.Files
'Month number from file's date created.
mn = Month(f.DateCreated)
'File's basename
fbn = fso.GetBaseName(f.Name)
'Find fbn in month name's column
Set fr = ws.Columns(mn + 1).Find(fbn)
If fr Is Nothing Then
ws.Cells(ws.Rows.Count, mn + 1).End(xlUp).Offset(1) = fbn
End If
Next f
ws.UsedRange.Columns.AutoFit
Next sfp

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub


'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, p As String, a() As String, v As Variant
Dim b() As Variant, i As Long, fso As Object

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
Set fso = CreateObject("Scripting.FileSystemObject")
p = fso.GetParentFolderName(myDir) & "\"
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
MsgBox myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
'add the folder name
a(i) = p & a(i)
End If
Next i

Set fso = Nothing
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function

[abdelfattah]

it must take from you more time I appreciate that , but unfortunately it gives me error "subscript out of range" in this line

Set ws = Worksheets(sf.ShortName) 'e.g. CSV, XLS, XLSM, etc.
I'm sure the sheets' names are matched with subfolders' names
may you guide me where I make mistake, please ?:think:

[Kenneth Hobs]

You must have a worksheet tab's name that does not exist but is a subfolder name. That is why I asked about that in question (1). To handle that, we can check if the worksheet tab name exists and if it does not exist, create it.

Before that line insert:

Debug.Print sf.ShortName
After the run, check the value in VBE's Immediate Window. If Immediate window is not visible, set it in VBE's View menu. This is the missing worksheet.

For an alternative-like solution to consider later or for others:
This does what #4 does but all looping by fso method alone. This one uses late binding for the fso object while mine uses early binding. Early bound object required that the reference object be set. That is why many use late binding methods. It can also avoid version issues. Advantage to early binding is that it makes intellisense work for that object library so it is good for beginning coders.


'some fso iteration parts from, https://stackoverflow.com/questions/22645347/loop-through-all-subfolders-using-vba
Sub MainAllFSO()
Dim fso As Object, oFolder As Object, oSubfolder As Object, oFile As Object, queue As Collection
Dim pfn As String, sfs, sfp, ws As Worksheet, fr As Range, mn As String, fbn As String

'Parent folder name
pfn = "d:\myfiles\t" 'obviously replace


Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder(pfn)

Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1 'dequeue

For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder 'enqueue
Next oSubfolder

'skip parent folder files
If LCase(oFolder.Path) = LCase(pfn) Then GoTo NextLoop
'Set worksheet for input: Assumes that each subfolder name has a worksheet name.
Set ws = Worksheets(oFolder.ShortName) 'e.g. CSV, XLS, XLSM, etc.
For Each oFile In oFolder.Files
'Month number from file's date created.
mn = Month(oFile.DateCreated)
'File's basename
fbn = fso.GetBaseName(oFile.Name)
'Find fbn in month name's column
Set fr = ws.Columns(mn + 1).Find(fbn)
If fr Is Nothing Then
ws.Cells(ws.Rows.Count, mn + 1).End(xlUp).Offset(1) = fbn
End If
Next oFile
ws.UsedRange.Columns.AutoFit
NextLoop:
Loop

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

[abdelfattah]

actually i tested both ways first no sheets are existed the code should created if it's not existed and it's existed in subfolders 'name should create it
and this exactly what I want as you design the macro
and the second I created the sheets are matched with subfolders 'name but it gives the same error
I used the second way because I thought you design macro based on second way that's why I told you
and what you suggest it just show DOCX in immediate window
and theses my subfolders as in picture
finally my version office is 2016
28265

[Kenneth Hobs]

I am sorry but English is the only language that I know so I may not see in your pic what you see.

In VBE, did you Debug > Compile before running Main()? This will often catch errors like not setting an object reference.

I am guessing that you are still seeing what I pointed out in #2's item (1). Your xlsx file did not contain a DOCX worksheet.

This is the same Main() as in #4 but includes adding the worksheet if it does not exist. You must first create a worksheet and name it Template. Set it up with the month columns in row 1 like your others without data below row 1. The other two supporting subs from #2 must be in this code's module or another. Obviously, change the value of pf as explained in #4.


Sub Main2()
Dim pf As String, sfs, sfp
'Tools > References > Microsoft Scripting Runtime
Dim fso As FileSystemObject, sf As Scripting.Folder, f As Scripting.File
Dim ws As Worksheet, fr As Range
Dim mn As String, fbn As String

'Parent Folder
pf = "d:\myfiles\t"

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Set fso = New FileSystemObject

'Array with Subfolder paths.
'http://www.vbaexpress.com/forum/showthread.php?58579-get-file-paths-based-on-name-criteria-from-folder
sfs = aFFs(pf, "/ad", True)

'No error check for subfolder paths put into sfs. At least one subfolder is assumed.
For Each sfp In sfs
Set sf = fso.GetFolder(sfp)
'Copy Template worksheet to new worksheet and with subfolder name.
If Not WorkSheetExists(sf.ShortName) Then
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = sf.ShortName
End If
'Set worksheet for input: Assumes that each subfolder name has a worksheet name.
Set ws = Worksheets(sf.ShortName) 'e.g. CSV, XLS, XLSM, etc.
For Each f In sf.Files
'Month number from file's date created.
mn = Month(f.DateCreated)
'File's basename
fbn = fso.GetBaseName(f.Name)
'Find fbn in month name's column
Set fr = ws.Columns(mn + 1).Find(fbn)
If fr Is Nothing Then
ws.Cells(ws.Rows.Count, mn + 1).End(xlUp).Offset(1) = fbn
End If
Next f
ws.UsedRange.Columns.AutoFit
Next sfp

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub


'WorkSheetExists in a workbook:
Function WorkSheetExists(sWorkSheet As String, Optional sWorkbook As String = "") As Boolean
Dim ws As Worksheet, wb As Workbook
On Error GoTo notExists
If sWorkbook = "" Then
Set wb = ActiveWorkbook
Else
Set wb = Workbooks(sWorkbook) 'sWorkbook must be open already. e.g. ken.xlsm, not x:\ken.xlsm.
End If
Set ws = wb.Worksheets(sWorkSheet)
WorkSheetExists = True
Exit Function
notExists:
WorkSheetExists = False
End Function

[abdelfattah]

it gives me error "aFFs "sub or function not defined in this

sfs = aFFs(pf, "/ad", True)
about the language just I want to see my subfolders' name are right or wrong to make sure when code search in subfolders name

[abdelfattah]

I fix it now it works but I have a question the code when bring the files in specific month then it copy Jan , FEB IN one column ,does the code create header months JAN,feb ...etc and bring the files to each month?

[Kenneth Hobs]

I explain most all steps in the comments.

Here, I get the month number for the file's Date Created file property. e.g. JAN=1

mn = Month(f.DateCreated)

Here, I add one to the mn value. For JAN, 1+1=2. So, column 2 is column B. I search that column for fbn, the file's base name (shortname).

'Find fbn in month name's column
Set fr = ws.Columns(mn + 1).Find(fbn)

If the range fr above is not found (Nothing), then I set the value of fr (first blank cell in column 2, B) to be the file's base name (shortname), fbn

ws.Cells(ws.Rows.Count, mn + 1).End(xlUp).Offset(1) = fbn

You can see file creation dates in File Explorer (Win+E). Those month numbers match my mn+1 column numbers which has the abbreviated month name in row 1. This is how you setup your worksheet row 1 in #1.

It is up to you to make row 1. You could delete all of your worksheets except the Template worksheet. Then after that first run, all of your worksheets will be created based on Template worksheet and filenames added. Run again after adding file(s) and just the new file names are added and worksheets only created if new subfolder was created since the last run.

[abdelfattah]

I have files in months 2,3,4 it copy all the files in one month in May we are in April
should copy to FEB,MAR,APR
this is strange

[Kenneth Hobs]

If you copied files for testing purposes, then the creation dates are all the same and would go into one column. View the file's creation dates. That is weird but that shows the case where a Modified date could be earlier than a Created date.

It may be that one might want to code it to use the oldest date whether that is creation or modification date.

[abdelfattah]

I attached file see sheets PDF,DOCX and compare with the dates as in picture

[Kenneth Hobs]

The pics do not help me as you did not use file explorer and show the property tags. Those on the left are more likely Date Modified. One has to right click on the header row and select the Date Created property typically.

It is a trivial matter to use Date Modified or more likely the better choice of oldest date as I explained in #13. I can show that either method if needed. It is a one word or 1 to 2 code line, respectively, to use those.

[abdelfattah]

so what you suggest to overcome this dilemma ?

[Kenneth Hobs]

I see in your #14 file that you removed column 1. I did not update those but those incremental numbers are easily added by the macro or by a an If() formula. They could simply be: =Row()-1

So, if you put JAN in column one, then the code needs to reflect that. Change mn+1 to mn.

As for the dates, here are the 3 ways that I discussed:

'Month number from file's date created.
'mn = Month(f.DateCreated)
'Month number from file's date modified.
'mn = Month(f.DateLastModified)
'Month number from file's oldest date created or date modified.
mn = Month(WorksheetFunction.Min(f.DateCreated, f.DateLastModified)

[abdelfattah]

yes you're right about delete column 1 now it moves to month APRIL and when use file explorer I found the modified date is in APRIL , also I took the last choice about date it works excellently and this is what I want thanks so much for achieving this a complicated project
just curiosity if I would add hyperlink in all files in all sheets to open the file if it's possible
thanks again :clap:

[Kenneth Hobs]

Most any concept you can think of has been done. e.g. Batch process folders/files. This is why threads by concept is better than threads by project. Concept threads get more replies. It essentially breaks a project into steps.

In the case of #18, hyperlink by methods: (1) by range hyperlink or (2) formula?

[abdelfattah]

by range hyperlink just directly open the file when press it by hyperlink

[Kenneth Hobs]

I will work on that but both methods do that.

For what it is worth, 2 other methods can accomplish the sample goal. For one, press or click a cell to trigger a worksheet selectionchange event. For a mouse doubleclick method, a worksheet beforedoubleclick event. These methods have trade-offs like any method.

[Kenneth Hobs]

Here is your one code line replacement solution:

'ws.Cells(ws.Rows.Count, mn + 1).End(xlUp).Offset(1) = fbn
ws.Hyperlinks.Add ws.Cells(ws.Rows.Count, mn + 1).End(xlUp).Offset(1), f.Path, , , fbn

[abdelfattah]

it doesn't add any hyperlink and doesn't gives me any error

[Kenneth Hobs]

Works fine for me. I "almost" never post code that I have not tested to some degree.

I can only guess that you already have the file basenames so it worked as designed and did not add another. Delete your existing data in backup copy of the file and run again...

[abdelfattah]

nothing changes :(

[abdelfattah]

it successes :yes
thanks for every thing

[Kenneth Hobs]

Then I can help no further as it works for me.

My last run used this. It uses the mn+1 that I discussed earlier. I also attached your original workbook with my macros. I like copy paste from files rather than forums as they don't post tab characters.


Sub Main4()
Dim pf As String, sfs, sfp
'Tools > References > Microsoft Scripting Runtime
Dim fso As FileSystemObject, sf As Scripting.Folder, f As Scripting.File
Dim ws As Worksheet, fr As Range
Dim mn As String, fbn As String

'Parent Folder
pf = "d:\myfiles\t"

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Set fso = New FileSystemObject

'Array with Subfolder paths.
'http://www.vbaexpress.com/forum/showthread.php?58579-get-file-paths-based-on-name-criteria-from-folder
sfs = aFFs(pf, "/ad", True)

'No error check for subfolder paths put into sfs. At least one subfolder is assumed.
For Each sfp In sfs
Set sf = fso.GetFolder(sfp)
'Copy Template worksheet to new worksheet and with subfolder name.
If Not WorkSheetExists(sf.ShortName) Then
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = sf.ShortName
End If
'Set worksheet for input: Assumes that each subfolder name has a worksheet name.
Set ws = Worksheets(sf.ShortName) 'e.g. CSV, XLS, XLSM, etc.
For Each f In sf.Files
'Month number from file's date created.
'mn = Month(f.DateCreated)
'Month number from file's date modified.
'mn = Month(f.DateLastModified)
'Month number from file's oldest date created or date modified.
mn = Month(WorksheetFunction.Min(f.DateCreated, f.DateLastModified))
'File's basename
fbn = fso.GetBaseName(f.Name)
'Find fbn in month name's column
Set fr = ws.Columns(mn + 1).Find(fbn)
If fr Is Nothing Then
'ws.Cells(ws.Rows.Count, mn + 1).End(xlUp).Offset(1) = fbn
ws.Hyperlinks.Add ws.Cells(ws.Rows.Count, mn + 1).End(xlUp).Offset(1), f.Path, , , fbn
End If
Next f
ws.UsedRange.Columns.AutoFit
Next sfp

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

[abdelfattah]

file is a great more again thanks for provide me the astonishing solution
best regards,
Abdelfattah