スラッシュドット・ジャパン

指定フォルダ(下位フォルダ含む)内のExcelブック(ファイル)のシート名をExcelに書き出す。 recursive

同一フォルダのExcelブック(ファイル)のシート名を一覧にするというのはネットでもあったが、
下位フォルダをも対象とするものは日本語はもちろん、英語でも検索したが探しきれなかった。
それ以上、探すより作った方が早いと思ったので、以前作ったのをちょっと修正して作った。

調べてないがVisioもシート名(ページ名)をVBAで取得できるんじゃないかと思う。

フォルダをダイアログで選択・指定したい場合は Shellオブジェクト(Shell.Application) 等を使えばいい。
    Office TANAKA - Excel VBA Tips[フォルダを選択するダイアログ]

'指定フォルダ(下位フォルダ含む)内のExcelブック(ファイル)のシート名をExcelに書き出す recursive
 
''対応済み。気にしなくていい→   '指定フォルダに"このExcelブック(ファイル)"は置かないこと。さもなくばOpenでエラーとなる。
'"このExcelブック(ファイル)"は処理の対象外とする
'フォルダの階層、Excelブック(ファイル)数、シート数によっては処理時間やPCの空きメモリに注意すること
 
'' 参考
''第6回 指定フォルダ内のファイル名一覧をExcelに書き出す：ITpro
'' <http://itpro.nikkeibp.co.jp/article/COLUMN/20060120/227645/>
'' .sheet(1) → .ActiveSheetに変更
''＠IT：Windows TIPS -- Tips：ファイルの一覧情報リストを取得する
'' <http://www.atmarkit.co.jp/fwin2k/win2ktips/310filelist/filelist.html>
 
Option Explicit
Sub MakeFileList4()
 
    Dim strPath, I
 
    Application.EnableEvents = False 'イベントの禁止
    Application.ScreenUpdating = False
 
    strPath = InputBox("調べたいフォルダを絶対パスで入力してください。", "ファイル一覧, シート一覧", "\\server-001\folder1\subfolder2")
    'Target = "\\server-001\folder1\subfolder2"
    'Target = "C:\Documents and Settings\UserName\My Documents\test"
 
    With ThisWorkbook.ActiveSheet
        'ThisWorkbook.Sheets("Sheet1").UsedRange.Delete
 
        'シートのクリア
        Cells.ClearContents
        'Clear 全てクリア
        'ClearContents 数式､文字列をクリア
        'ClearFormats 書式をクリア
        'ClearComments コメント文をクリア
        'ClearOutline アウトラインをクリア
 
        '見出しを付ける
        .Range("B2") = "ファイル名"
        .Range("C2") = "フォルダ名"
        '.Range("C2") = "フルパス(リンク)"
        .Range("D2") = "サイズ(KB)"
        .Range("E2") = "ファイル種別"
        .Range("F2") = "作成年月日"
        .Range("G2") = "最終アクセス年月日"
        .Range("H2") = "更新年月日"
 
        .Range("I2") = "シート名"
 
        .Range("B2:I2").Interior.Color = RGB(0, 0, 0)
        .Range("B2:I2").Font.Color = RGB(255, 255, 255)
        .Range("B2:Es2").HorizontalAlignment = xlCenter
 
        I = 3
 
        FileDisp strPath, I
 
        '.Columns("B:I").AutoFit
        .Columns("B:C").AutoFit
        .Columns("I").AutoFit
 
        Application.EnableEvents = True
        Application.ScreenUpdating = True '画面再描画再開
 
    End With
 
End Sub
 
Private Sub FileDisp(strPath, I)
    Dim objFS, objFLD, objFL, objSub
 
    With ThisWorkbook.ActiveSheet
        Set objFS = CreateObject("Scripting.FileSystemObject")
        Set objFLD = objFS.GetFolder(strPath)
        For Each objFL In objFLD.Files
 
''If objFL.Type = "Microsoft Excel ワークシート" Then  '@@@Excel のみを処理対象とするときはコメントを外すこと(コメント時はWord,Project,Visio,PDF,テキスト等全てのファイル種別を対象とする)
 
            .Cells(I, 2) = objFS.GetBaseName(objFL.Path)
            .Cells(I, 2) = objFS.GetFileName(objFL.Path)
            '.Cells(I, 3) = "<" & objFL & ">"
            .Cells(I, 3) = "<" & objFL.ParentFolder.Path & ">"
            .Cells(I, 4) = Int(objFL.Size / 1024)
            .Cells(I, 5) = objFL.Type
            .Cells(I, 6) = objFL.DateCreated
            .Cells(I, 7) = objFL.DateLastAccessed
            .Cells(I, 8) = objFL.DateLastModified
 
' ***
            If objFL.Type = "Microsoft Excel ワークシート" And objFL <> ThisWorkbook.FullName Then  'Excel のときのみシート名を出力する
 
                Dim J, N, K As Integer, wb2 As Workbook
 
                J = I
                Set wb2 = Workbooks.Open(objFL)
 
                N = wb2.Worksheets.Count
 
                For K = 1 To N
                    wb2.Worksheets(K).Select
                    If wb2.Worksheets(K).Name <> "" Then
                        .Cells(J, 9) = wb2.Worksheets(K).Name
                        J = J + 1
                    End If
                Next K
 
                wb2.Close SaveChanges:=False
 
                J = J - 1
                I = J
            End If
 
' ***
 
            I = I + 1
 
''End If                                               '@@@Excel のみを処理対象とするときはコメントを外すこと
 
        Next
        For Each objSub In objFLD.SubFolders
            FileDisp objSub.Path, I
        Next
 
    End With
 
End Sub

指定フォルダ内のファイル名一覧をExcelに書き出す2(再帰的に)…下位フォルダも対象

フォルダをダイアログで選択・指定したい場合は Shellオブジェクト(Shell.Application) 等を使えばいい。
    Office TANAKA - Excel VBA Tips[フォルダを選択するダイアログ]

'指定フォルダ内のファイル名一覧をExcelに書き出す2(再帰的に)…下位フォルダも対象
'参考
'第6回 指定フォルダ内のファイル名一覧をExcelに書き出す：ITpro
' <http://itpro.nikkeibp.co.jp/article/COLUMN/20060120/227645/>
' .sheet(1) → .ActiveSheetに変更
'＠IT：Windows TIPS -- Tips：ファイルの一覧情報リストを取得する
' <http://www.atmarkit.co.jp/fwin2k/win2ktips/310filelist/filelist.html>
 
Sub MakeFileList3()
 
    Application.EnableEvents = False 'イベントの禁止
    Application.ScreenUpdating = False
 
    strPath = InputBox("調べたいフォルダを絶対パスで入力してください。", "ファイル一覧", "\\server-001\folder1\subfolder2")
    'Target = "\\server-001\folder1\subfolder2"
 
    With ThisWorkbook.ActiveSheet
        'ThisWorkbook.Sheets("Sheet1").UsedRange.Delete
 
        'シートのクリア
        Cells.ClearContents
        'Clear 全てクリア
        'ClearContents 数式､文字列をクリア
        'ClearFormats 書式をクリア
        'ClearComments コメント文をクリア
        'ClearOutline アウトラインをクリア
 
        '見出しを付ける
        .Range("B2") = "ファイル名"
        .Range("C2") = "親フォルダ名"
        .Range("D2") = "サイズ(KB)"
        .Range("E2") = "ファイル種別"
        .Range("F2") = "作成年月日"
        .Range("G2") = "最終アクセス年月日"
        .Range("H2") = "更新年月日"
        .Range("B2:H2").Interior.Color = RGB(0, 0, 0)
        .Range("B2:H2").Font.Color = RGB(255, 255, 255)
        .Range("B2:Es2").HorizontalAlignment = xlCenter
 
        i = 3
 
        FileDisp strPath, i
 
        Application.EnableEvents = True
        Application.ScreenUpdating = True '画面再描画再開
 
    End With
 
End Sub
 
Private Sub FileDisp(strPath, i)
 
    With ThisWorkbook.ActiveSheet
        Set objFs = CreateObject("Scripting.FileSystemObject")
        Set objFld = objFs.GetFolder(strPath)
        For Each objFl In objFld.Files
            '.Cells(i, 2) = objFs.GetBaseName(objFl.Path)
            .Cells(i, 2) = objFs.GetFileName(objFl.Path)
            .Cells(i, 3) = objFl.ParentFolder.Path
            .Cells(i, 4) = Int(objFl.Size / 1024)
            .Cells(i, 5) = objFl.Type
            .Cells(i, 6) = objFl.DateCreated
            .Cells(i, 7) = objFl.DateLastAccessed
            .Cells(i, 8) = objFl.DateLastModified
            i = i + 1
        Next
        For Each objSub In objFld.SubFolders
            FileDisp objSub.Path, i
        Next
    End With
 
End Sub

指定フォルダ内のファイル名一覧をExcelに書き出す

フォルダをダイアログで選択・指定したい場合は Shellオブジェクト(Shell.Application) 等を使えばいい。
    Office TANAKA - Excel VBA Tips[フォルダを選択するダイアログ]

'指定フォルダ内のファイル名一覧をExcelに書き出す
'参考
'第6回 指定フォルダ内のファイル名一覧をExcelに書き出す：ITpro
' <http://itpro.nikkeibp.co.jp/article/COLUMN/20060120/227645/>
' .sheet(1) → .ActiveSheetに変更
 
Sub MakeFileList2()
 
Application.EnableEvents = False 'イベントの禁止
Application.ScreenUpdating = False
 
    '対象フォルダの指定
    Target = "\\server-001\folder1\subfolder2"
 
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set Fol = FS.GetFolder(Target)
    Set Fil = Fol.Files
 
    With ThisWorkbook.ActiveSheet
    'ThisWorkbook.Sheets("Sheet1").UsedRange.Delete
 
    'シートのクリア
    Cells.ClearContents
    'Clear 全てクリア
    'ClearContents 数式､文字列をクリア
    'ClearFormats 書式をクリア
    'ClearComments コメント文をクリア
    'ClearOutline アウトラインをクリア
 
    '見出しを付ける
    .Range("B2") = "ファイル名"
    .Range("C2") = "ファイル種別"
    .Range("D2") = "最終更新日"
    .Range("E2") = "説明"
    .Range("B2:E2").Interior.Color = RGB(0, 0, 0)
    .Range("B2:E2").Font.Color = RGB(255, 255, 255)
    .Range("B2:Es2").HorizontalAlignment = xlCenter
 
    i = 3
    For Each Fx In Fil
        'ファイル名
        sFile = Fx.Name
        'ファイル名の書き出し
        .Cells(i, 2) = sFile
        'ファイル種別
        sFType = Fx.Type
        '最終更新日時の書き出し
        .Cells(i, 3) = sFType
        '最終更新日
        sLMod = Fx.DateLastModified
 
        .Cells(i, 4) = sLMod
        i = i + 1
    Next
    End With
 
Application.EnableEvents = True
Application.ScreenUpdating = True '画面再描画再開
 
End Sub

Excelを使わないようにしようと思った時期もあったが、それは無理とわかった。
Excelを諦めるのを諦めた。
必要があれば適度に使うことにした。

かなり前に作ったExcel VBAをメモしていく。

わざわざアプリケーションインストールするまでもない、と思いネットを探したが、思うようなのがなかったので作った。
統一がとれてなかったり、ダサダサなんだけど、まぁ、よしとするか。
特にDirとか書いているところ、この関数使わずに書き直したいんだけど。

Public Sub CopyAllSheets()
 
'CopyAllSheets New Excel Book VBA
 
'指定したブック(Excelファイル)のシート、またそれと同じフォルダ内のブックのシートをこのブックにコピーするマクロ
'シート名に重複があるときはシート名(2)という具合にコピーする
'結果はシート名で昇順に並び変える。また空シートは削除する(コピーしない)
 
'*** 注意 *** 2007形式のブック(ファイル)を対象にする時は、本ブック(ファイル)を xlsm(マクロ有効な2007ブック形式)形式で保存しなおすこと
 
'画面の表示更新を止める(処理を速くするために)
Application.ScreenUpdating = False
 
'ダミーシート作成(Excelブックは最低1シートは存在してなければいけない)
Dim sh1 As Worksheet
Dim flag As Boolean
For Each sh1 In Worksheets
    If sh1.Name = "dummy0123456789" Then flag = True
Next sh1
If flag = False Then
   Worksheets.Add
   ActiveSheet.Name = "dummy0123456789"
End If
 
'既存シート削除
Dim sh2 As Worksheet
With ThisWorkbook.Sheets
    For Each sh2 In Sheets
        If Not (sh2.Name = "dummy0123456789") Then
            Application.DisplayAlerts = False
            sh2.Delete
            Application.DisplayAlerts = True
        End If
    Next
End With
 
'各ブックの各シートをコピー
Dim strPath As String
Dim index As Integer
Dim strFName As String
 
strPath = Application.GetOpenFilename
 
If strPath = "False" Then
    Exit Sub
End If
 
index = InStrRev(strPath, "\")
strPath = Left(strPath, index)
 
'シートのコピー
strFName = Dir(strPath & "*.xls*") '拡張子が2007タイプでも読み込むように。
'' 自分自身の(マクロを実行している)ブック名を取得
myfile = ThisWorkbook.Name
Do While strFName <> "" And strFName <> myfile  '自分自身はコピーの対象としない
        CopySheetsInBook (strFName)
        strFName = Dir()
Loop
 
' ダミーシート削除(空のワークシート削除より前で処理すること)
Application.DisplayAlerts = False   'メッセージを表示しない
With ThisWorkbook.Sheets
    Worksheets("dummy0123456789").Delete
End With
Application.DisplayAlerts = True
 
'空のワークシートを削除
Dim sh3 As Worksheet
Application.DisplayAlerts = False   'メッセージを表示しない
With ThisWorkbook.Sheets
    For Each sh3 In Worksheets
        If IsEmpty(sh3.UsedRange) = True Then
            sh3.Delete
        End If
    Next sh3
End With
Application.DisplayAlerts = True
 
'シートの並び替え(昇順)
Dim i As Byte
Dim j As Byte
 
For i = 1 To Sheets.Count - 1                 '---最初から最後の1つ前のシートまで
  For j = i + 1 To Sheets.Count               '---i番め以降のシート全て
     If Sheets(i).Name > Sheets(j).Name Then  '---シート名の比較
        Sheets(j).Move Before:=Sheets(i)      '---(1)シートの移動
     End If
  Next j
Next i
 
'最初のシートをアクティブにする
Dim Sh4 As Worksheet
With ThisWorkbook.Sheets
    Set Sh4 = Worksheets(1)
    Sh4.Activate
End With
 
'処理結果をこのファイルに保存する
Application.DisplayAlerts = False   'メッセージを表示しない
Dim book1 As Workbook
Set book1 = ThisWorkbook
book1.Save
Application.DisplayAlerts = True
 
' 画面の表示更新を再開する
Application.ScreenUpdating = True
 
MsgBox "結果を保存し、処理が終了しました。"
 
End Sub
 
'シートのコピー(サブ)
Private Sub CopySheetsInBook(strFName As String)
 
Dim NumOfSheets As Integer
Dim iSheets As Worksheet
 
NumOfSheets = Workbooks(1).Sheets.Count
Workbooks.Open strFName
With Workbooks(2)
    For Each iSheets In .Sheets
        iSheets.Copy after:=Workbooks(1).Worksheets(NumOfSheets)
        NumOfSheets = NumOfSheets + 1
    Next
    .Saved = True
    .Close
End With
 
End Sub

午後6時20分まで仕事。

天神まで歩いた。PARCO周辺は人が多かった。天神東宝 6番スクリーン（7階）で「恋するベーカリー」を見た。

全然、料理ものでなかった。タイトルに騙された。スティーブ・マーティンはコメディしないし、アレック・ボールドウィンは太ってるし。メリル・ストリープら三人の料理コメディと思っていたのに全く違った。10年前に分かれた夫婦が子供の卒業式をきっかけとして、家のリフォーム、娘の結婚準備、元夫の今の年下の妻との生活を絡めながら、よりが戻るか、戻らないかのコメディ。もちろん取り巻く人を含め、様々な思いも描かれているが。

映画としては良く出来ている。しかし誰が見ると想定してこの映画は作られたのだろうか？二週間で打ち切られる理由が分かる。

いつもあえて調べたりせず、タイトル、あるいはさらに出演者の情報だけでそれ以外の予備知識なしに映画を見るのだが今回は失敗した。大きく勘違いしていた。映画館でこれから公開される映画のCMが流れるが、それは見ている場合もある。しかし今回はそれも見てなかった。

恋するベーカリー - Wikipedia

ジュリー & ジュリアを見たばかりだったので、引き続きメリル・ストリープは期待していたのだが。

SUBARU OUTBACK、TOYOTA PRIUS、ポルシェ ケイマン？が出てくる。

車のフロントグラスに土埃がひどく、ウォッシャー液で洗い流した。黄砂か？

午後5時55分まで仕事。

午後6時30分まで仕事。

午後7時まで仕事。

午後6時30分まで仕事。