まりふのひと

Excel VBA/ファイルの一覧を作るマクロの例

VBA FS

PCを使っていない企業は無いと思うが、逆に管理が面倒になっていることはないだろうか？　との「年寄りの心配」（ヒョッとして冷や水かも）から、ＦＳ社の例を参考に「指定のフォルダ下にあるファイルの一覧を作る」マクロ（VBA）を作ってみた。
今後参考にするために記録する...

§１．Decraretions

  1. Option Explicit
  2. Const TXTFileName As String = "FolderList.txt"
  3. Const COLPathName As Long = 5　　 'フォルダー名
  4. Const COLFileName As Long = 6　　　 'ファイル名
  5. Dim BOOLAns As Boolean
  6. Dim LNGAns As Long
  7. Dim STRAns As String
  8. Dim VARAns As Variant


§２．Auto_Open

　　

  1. Sub Auto_Open()
  2. Dim mbTitle As String
  3. Dim strTopPath As String
  4. 　
  5. mbTitle = "Auto_Open/" & ThisWorkbook.Name
  6. strTopPath = Worksheets("更新履歴").Range("B2")
  7. Worksheets("CADNo").Select
  8. Range("D1").Select
  9. VARAns = MsgBox("CAD No.の一覧を作成します。" & vbCrLf & vbCrLf _
  10. & "　■前回トップフォルダ＝" & strTopPath & vbCrLf & vbCrLf _
  11. & "トップフォルダを変更する時は、［いいえ］を選択します。" _
  12. , vbYesNoCancel + vbExclamation, mbTitle)
  13. If VARAns = vbCancel Then Exit Sub
  14. If VARAns = vbNo Then strTopPath = ""
  15. 　
  16. If strTopPath = "" Then
  17. strTopPath = getフォルダ名()
  18. If strTopPath = "" Then Exit Sub
  19. End If
  20. 'トップフォルダーを保存する。
  21. Worksheets("更新履歴").Select
  22. Range("B1") = Now()
  23. Range("B2") = strTopPath
  24. 　
  25. BOOLAns = makeCADNoリスト(strTopPath)
  26. BOOLAns = 修整する()
  27. 　
  28. End Sub


§３．makeCADNoリスト

  1. Function makeCADNoリスト(argTopPath As String)
  2. Dim dsn As Long, i As Long
  3. Dim strTopPath As String, flnFolderList As String
  4. Dim strPath As String, strFileName As String
  5. 　
  6. flnFolderList = ThisWorkbook.Path & "\" & TXTFileName
  7. VARAns = makeフォルダーリスト(argTopPath, flnFolderList)
  8. 　
  9. Worksheets("CADNo").Select
  10. 'クリアする
  11. Range("A2").Select
  12. Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
  13. Selection.EntireRow.Delete
  14. Range("A2").Select
  15. 'フォルダーリストを読んでパスとファイル名を書き出す。
  16. dsn = FreeFile
  17. Open flnFolderList For Input As dsn
  18. i = 1
  19. Do Until EOF(dsn)
  20. Input #dsn, strPath
  21. '出力ファイル名を作る。
  22. If Right(strPath, 1) = "\" Then
  23. STRAns = strPath & "*.*"
  24. Else
  25. STRAns = strPath & "\*.*"
  26. End If
  27. strFileName = Dir(STRAns)
  28. Do Until strFileName = ""
  29. i = i + 1
  30. Cells(i, COLPathName) = strPath
  31. Cells(i, COLFileName) = strFileName
  32. strFileName = Dir()
  33. Loop
  34. Loop
  35. Close dsn
  36. 　
  37. End Function　


§４．makeフォルダーリスト

  1. Function makeフォルダーリスト(argTopFolder As String, argFolderList As String)
  2. Dim dsn As Long
  3. 　
  4. dsn = FreeFile
  5. Open argFolderList For Output As dsn
  6. 'トップフォルダーを出力する
  7. Print #dsn, argTopFolder
  8. VARAns = get全フォルダ名(argTopFolder, dsn)
  9. Close dsn
  10. 　
  11. End Function

§５．get全フォルダ名

再帰呼び出し（recursive call）を使って、全フォルダ名（パス名）をテキストファイルに書き出す。　

  1. Function get全フォルダ名(argPath As String, argDSN As Long)
  2. Dim mbTitle As String
  3. Dim obj As Object
  4. Dim strBuffer As String
  5. 　
  6. mbTitle = "get全フォルダ名/" & ThisWorkbook.Name
  7. With CreateObject("Scripting.FileSystemObject")
  8. For Each obj In .GetFolder(argPath).SubFolders
  9. VARAns = get全フォルダ名(obj.Path, argDSN)
  10. If Dir(obj.Path, vbDirectory) <> "" Then Print #argDSN, obj.Path
  11. Next obj
  12. End With
  13. 　
  14. End Function　　


§６．getフォルダ名

  1. Function getフォルダ名() As String
  2. 　
  3. With Application.FileDialog(msoFileDialogFolderPicker)
  4. .Title = "トップ フォルダーを指定してください。"
  5. If .Show = True Then
  6. getフォルダ名 = .SelectedItems(1)
  7. Else
  8. getフォルダ名 = ""
  9. End If
  10. End With
  11. 　
  12. End Function


§７．修整する

  1. Function 修整する() As Boolean
  2. Dim d As Long, i As Long, y As Long
  3. Dim lastRow As Long, lenTopPath As Long
  4. Dim strF1 As String, strF2 As String, strF3 As String
  5. Dim strTopPath As String, strString As String
  6. 　
  7. strTopPath = Worksheets("更新履歴").Range("B2")
  8. If Right(strTopPath, 1) = "\" Then strTopPath = Left(strTopPath, Len(strTopPath) - 1)
  9. lenTopPath = Len(strTopPath)
  10. lastRow = Cells(2, COLPathName).End(xlDown).Row
  11. '書式を文字列にする。
  12. Columns("A:D").Select
  13. Selection.NumberFormatLocal = "@"
  14. Range("A2").Select
  15. 　
  16. For i = 2 To lastRow
  17. strString = Cells(i, COLPathName)
  18. strString = Mid(strString, lenTopPath + 2)
  19. 'F1を作る。
  20. If strString = "" Then
  21. strF1 = ""
  22. Else
  23. y = InStr(strString, "\")
  24. If y = 0 Then
  25. strF1 = strString
  26. strString = ""
  27. Else
  28. strF1 = Left(strString, y - 1)
  29. strString = Mid(strString, y + 1)
  30. End If
  31. End If
  32. Cells(i, 1) = strF1
  33. 'F2を作る。
  34. If strString = "" Then
  35. strF2 = ""
  36. Else
  37. y = InStr(strString, "\")
  38. If y = 0 Then
  39. strF2 = strString
  40. strString = ""
  41. Else
  42. strF2 = Left(strString, y - 1)
  43. strString = Mid(strString, y + 1)
  44. End If
  45. End If
  46. Cells(i, 2) = strF2
  47. 　
  48. If strString = "" Then
  49. strF3 = ""
  50. Else
  51. y = InStr(strString, "\")
  52. If y = 0 Then
  53. strF3 = strString
  54. strString = ""
  55. Else
  56. strF3 = Left(strString, y - 1)
  57. strString = Mid(strString, y + 1)
  58. End If
  59. End If
  60. Cells(i, 3) = strF3
  61. 　
  62. strString = Cells(i, COLFileName)
  63. d = InStrRev(strString, ".")
  64. Cells(i, 4) = Left(strString, d - 1)
  65. Next
  66. 'CADNoを降順に並べる。
  67. Range("D1").Select
  68. ActiveWorkbook.Worksheets("CADNo").Sort.SortFields.Clear
  69. ActiveWorkbook.Worksheets("CADNo").Sort.SortFields.Add Key:=Range("D2:D" & lastRow), _
  70. SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
  71. xlSortTextAsNumbers
  72. With ActiveWorkbook.Worksheets("CADNo").Sort
  73. .SetRange Range("A1:F" & lastRow)
  74. .Header = xlYes
  75. .MatchCase = False
  76. .Orientation = xlTopToBottom
  77. .SortMethod = xlStroke
  78. .Apply
  79. End With
  80. 　
  81. 修整する = True
  82. 　
  83. End Function