シート名を取得して保存するVBA

業務フローをEXCELを描くことがよくありますが、そのとき

ご丁寧にもシート名に業務を書いてくださっている方がいらっしゃいます。

んで、業務一覧をまとめたいときに一々転記するのもかったるいんで

VBAでシート名を取得して一覧にするやつを組みました。

ファイルを読み込んで、保存するだけのいたってシンプルなものです。
例のごとくエラー制御は甘いままです。(いいかげん鍛えないと・・・)

フォーム側(ボタンを1個作る)

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

Private Sub btn_getSheetName_Click()

'refer
' http://officetanaka.net/excel/vba/tips/tips154.htm
' http://www.moug.net/tech/exvba/0060013.html
' http://vbaexcel.seesaa.net/article/148313379.html
' http://officetanaka.net/excel/vba/file/file02.htm
' http://excelvba.pc-users.net/func/func4.html


'
'   EXCELブックからシート名を取得して別のEXCELに出力する
'

    Dim getFile As Variant
    Dim setFile As Variant
    Dim retVal As String
    
    '処理時間計測用
    Dim startTime As Date
    Dim endTime As Date
    
    startTime = Now
    
    ChDir CurDir        'カレントディレクトリ
    '抽出対象と保存対象を読出
    getFile = Application.GetOpenFilename("EXCELファイル(*.xls),*.xls, EXCELファイル(*.xlsx),*.xlsx")
    setFile = Application.GetOpenFilename("EXCELファイル(*.xls),*.xls, EXCELファイル(*.xlsx),*.xlsx")
    
    If VarType(getFile) <> vbBoolean And VarType(setFile) <> vbBoolean Then
       retVal = Module1.getSheetName(getFile, setFile)
   
    End If
    
    endTime = Now
    
    'Debug.Print DateDiff("s", startTime, endTime)

End Sub

モジュール側

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

'refer
' http://plaza.rakuten.co.jp/motyan2005/diary/201010200000/
' http://officetanaka.net/excel/vba/variable/12.htm
' http://oshiete.goo.ne.jp/qa/4418255.html
Option Explicit


'
' 　対象のEXCELからシート名を取得する
'
Function getSheetName(inFile As Variant, outFile As Variant)
    
    Dim readBook As Object
    Dim readSheet As Object
    Dim saveBook As Object
    Dim saveSheet As Object
    
    Dim sheetsName As String
    
    Dim i As Long               '行カウンター
    
    Const FIRST = 1
    Const ROWA = "A"            'A列
    Const ROWB = "B"            'B列
    
       
    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)
    saveBook.Worksheets(FIRST).Name = sheetsName
       
    i = 1
    For Each readSheet In readBook.Sheets
        saveBook.Worksheets(FIRST).Range(ROWA & i) = i
        saveBook.Worksheets(FIRST).Range(ROWB & i) = readSheet.Name
        i = i + 1
    Next
    
    saveBook.Worksheets(FIRST).Range(ROWA & ":" & ROWB).EntireColumn.AutoFit
    
    'ファイルを閉じる
    readBook.Close
    Set readBook = Nothing
    saveBook.Close Savechanges:=True
    Set saveBook = Nothing
    
    ActiveWorkbook.Close False
    Application.Visible = True
    Application.DisplayAlerts = True

End Function