電帳法のためonedriveに溜めたファイル一覧表

質問

昨年の夏ごろから、電子帳簿保存法のために、注文書や見積書や納品書などのPDFファイルやWORD、EXECELファイルを、1つのフォルダに、取引先ごとにフォルダを作成して保存するようにしています。

そろそろ決算の時期も近づいているので、確認等の作業をやっていこうと思うのですが、取引先ごとのフォルダを１つ１つ確認していく作業が少し大変なような気がしてきました。

なので、注文書や見積書の入ったフォルダこのフォルダ内にあるファイルの一覧表を自動で作ってくれるような方法はありませんでしょうか？

どうぞ、ご教示の程よろしくお願い致します。

回答No.2

NuboChan

もう見てないかもしれませんが、
「サブディレクトリーに対応」に対応しました。
（階層フォルダーに対応させる事もできます、今回はここまでとします）

Option Explicit

Sub ファイル一覧の更新()
Dim ws As Worksheet
Dim folderPath As Variant
Dim count As Long

' ルートフォルダのパスを指定
Const RootPath As String = "C:\Users\user\Documents\指定フォルダのパス\"

' 対象のシートを指定
Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適切に変更

'初期化
ws.Range("A:B").Clear

Dim font1 As Font

Set font1 = Range("A1:B1").Font
font1.Size = 14
font1.Bold = True

ws.Range("A1") = "Path"
ws.Range("B1") = "Files.Name"

'ファイル名抽出（含むpath)
folderPath = RootPath
UpdateFileList folderPath, count

'-------------------------------------------------

Dim lastRow As Long
Dim i As Long
Dim dict As Object

' 最終行を取得
lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row

' 重複チェック用のディクショナリを作成
Set dict = CreateObject("Scripting.Dictionary")

' A列の値をCheckし、重複行を2色で分け
For i = 2 To lastRow
If dict.Exists(Range("A" & i).Value) Then
' 2回目以降のrgbAntiqueWhite
ws.Range("A" & i & ":B" & i).Interior.Color = RGB(250, 235, 215)
Else
' 初出の行はrgbPaleGoldenrod
ws.Range("A" & i & ":B" & i).Interior.Color = RGB(238, 232, 107)
' ディクショナリに追加
dict.Add ws.Range("A" & i).Value, Nothing
End If
Next i

ws.Columns("A:B").AutoFit

MsgBox "処理が終了しました。"

End Sub

Sub UpdateFileList(ByVal folderPath As String, ByRef count As Long)
Dim fileName As Variant
Dim subFolder As Object
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

For Each subFolder In fso.GetFolder(folderPath).SubFolders
UpdateFileList subFolder.Path, count
Next subFolder

For Each fileName In fso.GetFolder(folderPath).Files
count = count + 1
Cells(count + 1, 1) = folderPath
Cells(count + 1, 2) = fileName.Name
Next fileName

End Sub

回答No.1

NuboChan

せっかくEXCELがあるので

ExcelのVBAを使って、指定フォルダ内のファイル名一覧表を生成するのはいかがですか　？

コードは、最低限の機能しかありませんが手直しすればそこそこ使えると思います。
（サブディレクトリーに対応することもできます）

Sub ファイル一覧の更新()
Dim filename As String
Dim count As Long

' フォルダのパスを指定
Const Path As String = "C:\Users\user\Documents\指定フォルダのパス\" '

filename = Dir(Path)
Do While filename <> ""
count = count + 1
Cells(count + 1, 2) = filename
filename = Dir()
Loop
End Sub