Choc-Net!
Excel対象ディレクトリ内のエクセルからシート名をがっつり取ってくる
最終更新:
choc-net
-
view
Option Explicit Private Sub CommandButton1_Click() Dim dirName As String Dim buf As String Dim rowIndex As Integer Dim strFileName As String Dim targetBook As Workbook Dim targetSheet As Worksheet Dim ws As Worksheet Const cnsDIR = "\*.xls" 'Excelファイルのみ抽出 Application.ScreenUpdating = False 'フォルダ選択ダイアログ表示 With Application.FileDialog(msoFileDialogFolderPicker) '戻り値がない場合は処理を抜ける If Not .Show Then Exit Sub End If 'ディレクトリパスを格納する dirName = .SelectedItems(1) End With 'シートの挿入をする Worksheets.Add Set targetSheet = ActiveSheet rowIndex = rowIndex + 1 'ディレクトリ名を表示する targetSheet.Cells(rowIndex, 1).Value = dirName ' 先頭のファイル名の取得 strFileName = Dir(dirName & cnsDIR, vbNormal) ' ファイルが見つからなくなるまで繰り返す Do While strFileName <> "" Workbooks.Open dirName & "\" & strFileName Set targetBook = ActiveWorkbook 'ブック名を指定して非表示 Application.Windows(strFileName).Visible = False rowIndex = rowIndex + 1 'エクセル名を表示する targetSheet.Cells(rowIndex, 2).Value = strFileName '全シート名を取得する。 For Each ws In targetBook.Worksheets rowIndex = rowIndex + 1 targetSheet.Cells(rowIndex, 3).Value = ws.Name Next 'ブックを閉じる targetBook.Close SaveChanges:=False ' 次のファイル名を取得 strFileName = Dir() Loop Application.ScreenUpdating = True If MsgBox("シート取得ボタンの画面に戻りますか?", vbYesNo, "処理が完了しました。") = vbYes Then Sheet1.Select End If End Sub