Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 28

Thread: create sheets based on extensions files and copy to each months

  1. #1

    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
    Attached Files Attached Files

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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?

  3. #3
    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
    Last edited by abdelfattah; 04-07-2021 at 08:41 AM.

  4. #4
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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

  5. #5
    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 ?

  6. #6
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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

  7. #7
    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
    Attached Images Attached Images
    • File Type: jpg 1.JPG (18.1 KB, 7 views)
    Last edited by abdelfattah; 04-07-2021 at 01:09 PM.

  8. #8
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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

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

  10. #10
    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?

  11. #11
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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.

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

  13. #13
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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.

  14. #14
    I attached file see sheets PDF,DOCX and compare with the dates as in picture
    Attached Images Attached Images
    • File Type: jpg 1.JPG (19.7 KB, 6 views)
    • File Type: jpg 2.JPG (14.8 KB, 6 views)
    Attached Files Attached Files

  15. #15
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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.

  16. #16
    so what you suggest to overcome this dilemma ?

  17. #17
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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)

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

  19. #19
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    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?

  20. #20
    by range hyperlink just directly open the file when press it by hyperlink

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •