create sheets based on extensions files and copy to each months

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-pro...ch-months.html

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?

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

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().

Code:

---

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

---

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

Code:

---

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:

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:

Code:

---

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.

Code:

---

'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

---

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
Attachment 28265

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.

Code:

---

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

---

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

Code:

---

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

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?

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

Code:

---

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).

Code:

---

'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

Code:

---

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.

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

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.

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

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.

so what you suggest to overcome this dilemma ?

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:

Code:

---

      '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)

---

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:

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?

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

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.

Here is your one code line replacement solution:

Code:

---

'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

---

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

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...

nothing changes :(

it successes :yes
thanks for every thing

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.

Code:

---

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

---

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