modified code and restrict splitting files each 10 files in each column

Alaa mg · Jul 13, 2021

hi
I have this code it brings all information from the subfolders & files , then create hyperlink and open it in two columns A,B , but what I look for it . it should split each 10 file in specific column individually . so when bring the subfolders under each of them should split each 10 files in separately column with the same borders and formatting as in my picture .
I hope my idea is clear

VBA Code:

Public oldNR As Long
Sub HyperlinkDirectory()

Dim fPath As String
Dim fType As String
Dim fname As String
Dim NR As Long
Dim AddLinks As Boolean

'Select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
         .InitialFileName = "C:\Users\OSE\Desktop\11\"
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With

'Types of files
    fType = Application.InputBox("What kind of files? Type the file extension to collect" _
            & vbLf & vbLf & "(Example:  xls, doc, txt, pdf, *)", "File Type", "PDF", Type:=2)
    If fType = "False" Then Exit Sub

'Option to create hyperlinks
    AddLinks = MsgBox("Add hyperlinks to the file listing?", vbYesNo) = vbYes

'Create report
    Application.ScreenUpdating = False
    NR = 4
    With ActiveSheet
        .Range("A:C").Clear
        .[A2] = "LIST OF FILES"
        .[B2] = "Modified Date"

        Call FindFilesAndAddLinks(fPath, fType, NR, AddLinks)

        End With
        With ActiveSheet
          .Range("A:B").Columns.AutoFit
          .Range("B:B").HorizontalAlignment = xlCenter

        Range("B:B").Select
        Selection.NumberFormat = "d-mmm-yy  h:mm AM/pm"
        End With

        With ActiveSheet
        Range("A2").Select
        Selection.Font.Bold = True
        Range("B2").Select
        Selection.Font.Bold = True
        Columns("A:A").Select
        Selection.Font.Underline = xlUnderlineStyleNone
    End With

    Application.ScreenUpdating = True

End Sub

Private Sub FindFilesAndAddLinks(fPath As String, fType As String, ByRef NR As Long, AddLinks As Boolean)
Dim fname As String
Dim oFS As New FileSystemObject
Dim oDir


'Files under current dir
fname = Dir(fPath & "*." & fType)
With ActiveSheet

    'Write folder name
    .Range("A" & NR) = fPath
    .Range("A" & NR).Select
    If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
           Address:=fPath, _
            TextToDisplay:="FOLDER NAME:  " & "  " & UCase(Split(fPath, "\")(UBound(Split(fPath, "\")) - 1))
             Selection.Font.Bold = True
             Selection.Font.Size = 10
             Selection.Font.Name = "Arial"
             Selection.Font.Underline = xlUnderlineStyleNone
             With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With

    With Selection.Font
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
    End With

    NR = NR + 2

    Do While Len(fname) > 0

      'filename
        If .Range("A" & NR) <> "" Then Debug.Print "Overwriting " & NR
        .Range("A" & NR) = fname
              'modified
        .Range("B" & NR) = FileDateTime(fPath & fname)

      'hyperlink
        .Range("A" & NR).Select
        If AddLinks Then .Hyperlinks.Add Anchor:=Selection, _
            Address:=fPath & fname, _
            TextToDisplay:=fname

      'set for next entry
        NR = NR + 1
        fname = Dir
    Loop

    'Files under sub dir
    Set oDir = oFS.GetFolder(fPath)
    For Each oSub In oDir.SubFolders
        NR = NR + 1
        Call FindFilesAndAddLinks(oSub.Path & "\", fType, NR, AddLinks)
    Next oSub
End With

        ActiveWindow.DisplayGridlines = False

End Sub

ff.xlsm