Consulting

Page 2 of 2 FirstFirst 1 2
Results 21 to 28 of 28

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

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

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

  3. #23
    it doesn't add any hyperlink and doesn't gives me any error

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

  5. #25
    nothing changes

  6. #26
    it successes
    thanks for every thing

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

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

Posting Permissions

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