Dim numOfDelimiter As Long

Sub mainFFs()

   'Declare
   Dim subFolders As Object
   Dim Path As String
   Dim rowP As Long
   Dim culP As Long
   Dim numOfSubF As Long
   Dim buf As String

   'Set values

   Path = "C:\Users\" 'ここに一番上のフォルダを指定してくださいね
   rowP = 1
   culP = 1

   'Pathに \ が何個あるか数える
   numOfDelimiter = UBound(Split(Path, "\"))

   '指定したフォルダだけ、書いてしまう
   Cells(1, 1) = Path
   culP = culP + 1
   buf = Dir(Path & "\*.*")
   Do While buf <> ""
       Cells(rowP, culP) = buf
       rowP = rowP + 1
       buf = Dir()
   Loop

   Call writeSubFFs(Path, culP, rowP)

End Sub

Sub writeSubFFs(Path As String, culP As Long, rowP As Long)

   '階層の調整
   Dim curPath As Long '文字カウント数
   curPath = UBound(Split(Path, "\"))

   If curPath <= numOfDelimiter + 1 Then
       culP = 3
   Else
       culP = culP + 1
   End If

   '*** Process ****

   '①フォルダ取得
   Set subFolders = CreateObject("Scripting.FileSystemObject").GetFolder(Path).subFolders

   For Each subFolders In subFolders

   '②フォルダ記載

       Path = subFolders.Path
       Cells(rowP, culP) = Path

   '③ファイル取得
       culP = culP + 1
       On Error Resume Next
       buf = Dir(Path & "\*.*")
   '④ファイル記載
       Do While buf <> ""
           Cells(rowP, culP) = buf
           rowP = rowP + 1
           buf = Dir()
       Loop


       culP = culP - 1
       rowP = rowP + 1

       Call writeSubFFs(Path, culP, rowP)

   Next subFolders
End Sub