EXCELのシート名取得、フォルダ名の取得マクロ完成版

前回の宿題事項の下記4点について対応できた。
思ったよりあっさりと実装できた。

1.EXCELシートのシート名を引いてくるのと選択式にする。

　→選択式にしやした。

2.ファイル名を再帰的に取得するのかしないのかを選択式にする

3.再帰的に取得する場合にフォルダ名も取得するのか選択式にする

4.フォルダ名の取得を選択式にする。

　→フォルダを選択すれば再帰的に出力するように改修

モジュール以外にも手を入れるところがあったんで。

フォーム

フォームモジュール側

-----------------------------------------------------------------------------------------------------------------------

Option Explicit
Sub getFileName_Click()
'
'   フォルダからファイル名を取得して一覧にして別のEXCELシートに保存する。
'
    Dim dlg As Object
    Dim dlgAns As Boolean
    Dim getForder As Variant    '取得対象フォルダ
    Dim getFile As Variant      '取得対象ファイル
    Dim outSheet As Variant     '出力用シート
    Dim retVal As String
    Dim optSelect As String
    Dim startTime As Date       '処理時間計測用
    Dim endTime As Date         '処理時間計測用
    
    startTime = Now
    
    'カレントディレクトリの指定
    ChDir CurDir
    '保存対象ファイルの指定
    outSheet = Application.GetOpenFilename("EXCELファイル(*.xlsx),*.xlsx , EXCELファイル(*.xls),*.xls", Title:="保存先の指定")
    If outSheet = False Then
        MsgBox ("保存するEXCELファイルを選択してください。")
        Exit Sub
    End If
        
    'モードの指定(今後のこと考えると要検討)
    If OptionButton1.Value = True Then
       optSelect = "E"
    End If
    If OptionButton2.Value = True Then
        optSelect = "F"
    End If
    
    Select Case optSelect
        Case "E"
            '取得対象EXCELの場合
            getFile = Application.GetOpenFilename("EXCELファイル(*.xlsx),*.xlsx,EXCELファイル(*.xls),*.xls")
            If getFile = outSheet Then
                MsgBox ("取得対象と出力先に同じEXCELファイルは指定できません。")
            ElseIf VarType(getFile) <> vbBoolean Then
               retVal = Module1.getSheetName(getFile, outSheet)
            Else
                MsgBox ("取得対象のEXCELファイルを選択してください。")
            End If
        Case "F"
            'ファイル名取得対象フォルダの指定
            Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
            dlgAns = dlg.Show
            If dlgAns Then
               getForder = dlg.SelectedItems(1)
            Else
               getForder = ""
            End If
            If getForder <> "" Then
               retVal = Module1.getFileName(getForder, outSheet)
            Else
                MsgBox ("取得対象フォルダが選択されていません。")
            End If
        Case Else
            MsgBox ("定義されていない設定です。システム管理者に連絡してください。")
    End Select
    
    endTime = Now
    'Debug.Print DateDiff("s", startTime, endTime)

End Sub

--------------------------------------------------------------------------------------------------------------------------------

標準モジュール側

-------------------------------------------------------------------------------------------------------------------------------

Option Explicit
'refer
' http://ameblo.jp/gidgeerock/entry-11584846307.html
' https://oshiete.goo.ne.jp/qa/1828986.html
' http://officetanaka.net/excel/vba/file/file07.htm
' http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html
' http://officetanaka.net/excel/vba/tips/tips39.htm
' https://gist.github.com/gitspopovic/2963865
' http://vba-geek.jp/blog-entry-294.html
' http://vbaexcel.seesaa.net/article/148305417.html
' http://d.hatena.ne.jp/bhunji2000/20091030/1258133771
' http://www.239-programing.com/excel-vba/func/func072.html
' v2 ref
' https://www.moug.net/tech/exvba/0150120.html
' http://officetanaka.net/excel/vba/sheet/sheet03.htm
' http://hensa40.cutegirl.jp/archives/705
' http://www.niji.or.jp/home/toru/notes/8.html
' http://officetanaka.net/excel/vba/tips/tips130.htm
' http://excel-ubara.com/excelvba4/EXCEL222.html
' http://www.officepro.jp/excelvba/sheet/index2.html
' https://support.microsoft.com/ja-jp/help/950220
' http://vba-geek.jp/blog-entry-269.html
' http://excelwork.info/excel/endproperty/
' http://www.atmarkit.co.jp/ait/articles/1402/24/news108.html
' v3 ref
' http://www.officepro.jp/excelvba/sub/index6.html
' http://officetanaka.net/excel/vba/statement/OnError.htm
' http://officetanaka.net/excel/vba/tips/tips104.htm
' http://officetanaka.net/excel/vba/tips/tips28.htm
' http://www.atmarkit.co.jp/ait/articles/1407/07/news011.html
' http://excelwork.info/excel/hyperlinks/
' http://officetanaka.net/excel/vba/tips/tips90.htm


'
' 　対象のフォルダからファイル名一覧を取得してEXCELシートに保存する
'
Function getFileName(infile As Variant, outFile As Variant)
On Error GoTo Error_Sub

    Const ROWA = "A"            'A列
    Const ROWB = "B"            'B列
    Const ROWC = "C"            'C列
    Const ROWD = "D"            'D列
    
    Dim saveBook As Object
    Dim saveSheet As Object
    Dim sheetsname As String
    Dim fullPath As String
    Dim firstSheet As Long      '書込み対象シートのインデックス
    Dim subFolderflg As String
    Dim fileSetret As String
    Dim saveWorksheet As Worksheet

    '保存先指定
    Set saveBook = Workbooks.Open(outFile)
    Application.DisplayAlerts = False
    Application.Visible = False
    
    With CreateObject("Scripting.FileSystemObject")
        'シート名設定
        sheetsname = .GetFolder(infile).Name
        sheetsname = sheetNameReplacer(sheetsname)
        '保存先シートの設定
        firstSheet = SheetChecker(saveBook, sheetsname)
        
        If firstSheet = 0 Then
            MsgBox ("シートの処理中にエラーが発生しました。")
            Exit Function
        End If
            
        Set saveWorksheet = saveBook.Worksheets(firstSheet)
        saveWorksheet.Activate
        'タイトル
        saveWorksheet.Range(ROWA & 1) = "NO"
        saveWorksheet.Range(ROWB & 1) = "ファイル名"
        saveWorksheet.Range(ROWC & 1) = "ファイルパス"
        saveWorksheet.Range(ROWD & 1) = "最終更新日時"
        
        fileSetret = FileSet(infile, saveWorksheet, 2)
   
   End With
    
    'シート名を変更し保存先EXCELを閉じる
    If fileSetret = "True" Then
        saveWorksheet.Name = sheetsname
    End If
        
    saveBook.Close Savechanges:=True
    Set saveBook = Nothing
    MsgBox ("処理が完了しました。")

    'ActiveWorkbook.Close False
    Application.Visible = True
    Application.DisplayAlerts = True
    Exit Function

Error_Sub:
    MsgBox ("システム管理者に以下の内容を連絡してください。" & Err.Number & ":" & Err.Description)
 
End Function

'
' 　対象のEXCELからシート名を取得する
'
Function getSheetName(infile As Variant, outFile As Variant)
On Error GoTo Error_Sub
   
    Const ROWA = "A"            'A列
    Const ROWB = "B"            'B列
    Const ROWC = "C"            'C列
   
    Dim readBook As Object
    Dim readSheet As Object
    Dim saveBook As Object
    Dim saveSheet As Object
    Dim sheetsname As String
    Dim i As Long               '行番号
    Dim firstSheet As Long      '書込み対象シートのインデックス
    Dim hyperAddr As String     'ハイパーリンク先
    Dim saveWorksheet As Worksheet
       
    i = 2
    Set readBook = GetObject(infile)
    Set saveBook = Workbooks.Open(outFile)
    Application.DisplayAlerts = False
    Application.Visible = False
    
    'シート名設定用
    sheetsname = left(readBook.Name, InStrRev(readBook.Name, ".", -1, vbTextCompare) - 1)
    sheetsname = sheetNameReplacer(sheetsname)

    '保存先シートの設定
    firstSheet = SheetChecker(saveBook, sheetsname)
    
    If firstSheet = 0 Then
        MsgBox ("シートの処理中にエラーが発生しました。")
        Exit Function
    End If
       
    '指定したEXCEL内のシート名を取得してEXCELに出力
    Set saveWorksheet = saveBook.Worksheets(firstSheet)
    saveWorksheet.Activate
    'タイトル
    saveWorksheet.Range(ROWA & 1) = "NO"
    saveWorksheet.Range(ROWB & 1) = "シート名"
    saveWorksheet.Range(ROWC & 1) = "ファイル名"
    
    For Each readSheet In readBook.Sheets
        hyperAddr = "=HYPERLINK(" & """" & infile & "#" & readSheet.Name & "!A1""" & "," & _
                    """" & readBook.Name & "_" & readSheet.Name & """)"
        saveWorksheet.Range(ROWA & i) = i
        saveWorksheet.Range(ROWB & i) = readSheet.Name
        saveWorksheet.Range(ROWC & i) = hyperAddr
        i = i + 1
    Next
    
    saveWorksheet.Range(ROWA & ":" & ROWC).EntireColumn.AutoFit
    saveWorksheet.Name = sheetsname
    
    'ファイルを閉じる
    readBook.Close
    Set readBook = Nothing
    saveBook.Close Savechanges:=True
    Set saveBook = Nothing
    
    MsgBox ("処理が完了しました。")
    
'    ActiveWorkbook.Close False
    Application.Visible = True
    Application.DisplayAlerts = True
    Exit Function

Error_Sub:
    MsgBox ("システム管理者に以下の内容を連絡してください。" & Err.Number & ":" & Err.Description)
    readBook.Close
    Set readBook = Nothing

End Function

'
'   EXCELシート操作
'   シートが存在しない場合はシートを追加
'　 同一シート名がある場合は別名シートで追加
'　 該当シートにデータが存在する場合はシート追加
'
'   引数　：チェック対象のシート
'　 戻り値：シート番号
'
Function SheetChecker(checkBook As Object, sheetsname As String) As Long
On Error GoTo Error_Sub
    
    Const LastCol = 5           '最終セル判定用
    Dim i As Long
    Dim chkRow As Long         '最終セル文字列判定用カウンター
    Dim chkcolumn As Long      '最終セル文字列判定用カウンター
    Dim cellCheck As Variant
        
    For i = 1 To checkBook.Worksheets.Count
        '同じシート名が存在する場合は別のシート名にする。
        'EXCELのシート名は31文字までなので制限に引っかからないように文字数を制限
        If sheetsname = checkBook.Worksheets(i).Name Then
            sheetsname = left(sheetsname, 10) & "_" & Format(Now, "yyyymmddhhmmss")
        End If
        
        '終端セル確認(よほどのことがない限り5列程度の確認で問題ないと思われる。)
        For chkcolumn = 1 To LastCol
            chkRow = checkBook.Worksheets(i).Cells(Rows.Count, chkcolumn).End(xlUp).Row
            cellCheck = checkBook.Worksheets(i).Cells(chkRow, chkcolumn).Value
            If cellCheck <> "" Then
                Exit For
            End If
        Next chkcolumn
        
        '終端セルにデータがないので該当シートに追記
        If cellCheck = "" Then
            SheetChecker = i
            Exit Function
        End If
        
        '追加が必要な場合はシートを追加する。
        If i = checkBook.Worksheets.Count Then
            checkBook.Worksheets.Add after:=checkBook.Worksheets(i)
            SheetChecker = i + 1
            Exit Function
        End If
    Next i

Error_Sub:  'あまりよろしくないが予期せぬエラー処理
    SheetChecker = 0
    MsgBox ("システム管理者に以下の内容を連絡してください。" & Err.Number & ":" & Err.Description)

End Function
'
'シート名対策用文字列置換
'   シートが存在しない場合はシートを追加
'　 同一シート名がある場合は別名シートで追加
'　 該当シートにデータが存在する場合はシート追加
'
'   引数　：シート名
'　 戻り値：変換後のシート名
'
Function sheetNameReplacer(sheetsname As Variant) As String
On Error GoTo Error_Sub

    Const CHECK = 12

    Dim replaceWork As String
    Dim strLeng As Long
    Dim i As Long
    Dim Prohibition(CHECK) As String
    
    'EXCELシート名の禁則文字
    Prohibition(0) = ":"
    Prohibition(1) = "："
    Prohibition(2) = "\"
    Prohibition(3) = "￥"
    Prohibition(4) = "/"
    Prohibition(5) = "／"
    Prohibition(6) = "?"
    Prohibition(7) = "？"
    Prohibition(8) = "*"
    Prohibition(9) = "＊"
    Prohibition(10) = "["
    Prohibition(11) = "]"
    
    replaceWork = sheetsname
    
    For i = 0 To CHECK
        replaceWork = Replace(replaceWork, Prohibition(i), "★")
    Next i
    
   strLeng = Len(replaceWork)
    
   If strLeng > 20 Then
        replaceWork = left(replaceWork, 15)
   End If
   
   sheetNameReplacer = replaceWork
   Exit Function

Error_Sub:  'あまりよろしくないが予期せぬエラー処理
    replaceWork = "False"
    MsgBox ("システム管理者に以下の内容を連絡してください。" & Err.Number & ":" & Err.Description)

End Function
'
' フォルダを取得しサブフォルダ名含めてEXCELに出力する。
' http://officetanaka.net/excel/vba/tips/tips36.htm　まんま
'
Function FileSet(Path As Variant, setWorksheet As Worksheet, sCol As Long) As String
On Error GoTo Error_Sub
    
    Const ROWA = "A"            '番号
    Const ROWB = "B"            'ファイル名
    Const ROWC = "C"            'ファイルパス
    Const ROWD = "D"            '更新日時
    Const ROWE = "E"            '容量
    
    Dim FSO As Object, Folder As Variant, File As Variant
    Dim i As Long
        
    Set FSO = CreateObject("Scripting.FileSystemObject")
    i = sCol
    
    'サブフォルダ探索
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSet(Folder.Path, setWorksheet, i)
    Next Folder
    
    For Each File In FSO.GetFolder(Path).Files
        setWorksheet.Range(ROWA & i) = i - 1        '番号を振るので-1しておく
        setWorksheet.Range(ROWB & i) = File.Name
        setWorksheet.Range(ROWC & i) = File.Path
        setWorksheet.Hyperlinks.Add Anchor:=Range(ROWC & i), Address:=File.Path
        setWorksheet.Range(ROWD & i) = File.DateLastModified
        i = i + 1
    Next File
    sCol = i

    'セルの整形
    setWorksheet.Range(ROWA & ":" & ROWD).Columns.AutoFit
    FileSet = "True"
    Exit Function

Error_Sub:  'あまりよろしくないが予期せぬエラー処理
    FileSet = "False"
    MsgBox ("システム管理者に以下の内容を連絡してください。" & Err.Number & ":" & Err.Description)
    
End Function

-------------------------------------------------------------------------------------------------------------------------------

ひとまずこれで完成、後は容量とか属性とかの話なので

ほしいのがあったらここに順次足していけばよい。

これでフォルダからファイル一覧調べろとか

フォルダ内で容量くってるファイル調べろとか言うときに

時短できますな。