今度はファイル名を取得する必要が出てきたので

この前は業務フローをシートにというパターンでしたが
今回はファイル1個に業務を記載してくれているパターンなので
指定したフォルダからファイル名の一覧を抜き出す必要が出てきました。
とゆうかシートの業務一覧とかファイル名のとか統一しろよと思いつつも・・・・。
両方組合せとかその他イレギュラーパターンも多々あるしそれは今後の話ということで
ひとまずはマクロ組んでみました。
とりあえず40を超えてから3社転職してるんで、こういうのは蓄積しておかないと。
忘れるし。パッケージみたいになっているほうがありがたい。

フォーム側
-----------------------------------------

Sub getFileName_Click()
'
'   フォルダからファイル名を取得して一覧にして別のEXCELシートに保存する。
'
    Dim dlg As Object
    Dim dlgAns As Boolean
    Dim getForder As Variant
    Dim outSheet As Variant
    Dim retVal As String
    Dim startTime As Date       '処理時間計測用
    Dim endTime As Date         '処理時間計測用
    
    startTime = Now
    'カレントディレクトリの指定
    ChDir CurDir
    
    'ファイル名取得対象フォルダの指定
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    dlgAns = dlg.Show
    If dlgAns Then
       getForder = dlg.SelectedItems(1)
    Else
       getForder = ""
    End If
     
    '保存対象ファイルの指定
    outSheet = Application.GetOpenFilename("EXCELファイル(*.xlsx),*.xlsx , EXCELファイル(*.xls),*.xls")
     
    If getForder <> "" And VarType(outSheet) <> vbBoolean Then
       retVal = Module1.getFileName(getForder, outSheet)
    Else
        MsgBox ("取得するフォルダが選択されていないか、保存先が指定されていません。")
    End If
     
    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

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

    Dim f As Object
    Dim saveBook As Object
    Dim saveSheet As Object
    Dim sheetsName As String
    Dim fullPath As String
    Dim i As Long               '行カウンター
    Const FIRST = 1
    Const ROWA = "A"            'A列
    Const ROWB = "B"            'B列

    '保存先指定
    Set saveBook = Workbooks.Open(outFile)
    Application.DisplayAlerts = False
    Application.Visible = False
    i = 1   '保存シート開始番号
    With CreateObject("Scripting.FileSystemObject")
         'シート名設定
         sheetsName = .GetFolder(inFile).Name
         saveBook.Worksheets(FIRST).Name = sheetsName
         'ファイル名の取得
         For Each f In .GetFolder(inFile).Files
            fullPath = inFile & "\" & f.Name
            saveBook.Worksheets(FIRST).Range(ROWA & i) = f.Name
            saveBook.Worksheets(FIRST).Range(ROWB & i) = fullPath
            saveBook.Worksheets(FIRST).Hyperlinks.Add Anchor:=Range(ROWB & i), Address:=fullPath
            i = i + 1
         Next f
    End With
    saveBook.Worksheets(FIRST).Range(ROWA & ":" & ROWB).Columns.AutoFit

    '保存先EXCELを閉じる
    saveBook.Close Savechanges:=True
    Set saveBook = Nothing

    ActiveWorkbook.Close False
    Application.Visible = True
    Application.DisplayAlerts = True
 
End Function