HappyTech's VBA Page Illustration by M.Fukumoto (C) HappyTech & Y.Nagai Home
すぐマク
http://www.max.hi-ho.ne.jp/happy/ since 2003.6

組み方講座 Support
本文 章タイトル ボイント
実践編第1章6 指定フォルダ内の全てのブックを順に開く Excel98、2001、v.X用 (Macintosh)

'=========================================================================================
 Excelマクロ組み方講座 指定フォルダ内の全てのブックを順に開いて作業する
=========================================================================================
Option Explicit
Dim 絶対パス, 親フォルダパス, 作業フォルダパス, 開くフォルダパス
Dim 取得名, ブック名
Dim 貼付行, 下端行
Dim カウンタ, 文字数, 結果
Dim メッセージ, 応答
Const タイトル As String _
        = "[ファイルの場所]を選択し、どれかのブックを選択して[開く]をクリックしてください"
Const 拡張子 As String = "*.xls"
-----------------------------------------------------------------------------------------
Sub 指定フォルダ内の全てのブックを順に開いて作業する()
    作業用シートをクリアする
    ダイアログを表示してフォルダへのパスをセットする
    If 絶対パス <> False Then
        フォルダ名とサブフォルダ名を取得してシートにセットする
        各フォルダ中のブック名を取得してシートにセットする
        メッセージ = "ブック名をリストアップしました。" & vbLf & "作業を続けますか?"
        応答 = MsgBox(メッセージ, vbYesNo, "Excelマクロ組み方講座")
        If 応答 = vbYes Then
            ブックを順に開いて作業する
        End If
    End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub 作業用シートをクリアする()
    Worksheets("ブック名").Activate             'ブック名をセットするシート
        Cells.Clear                             'すべてのセルをクリア
    Worksheets("フォルダ名").Activate           'フォルダ名をセットするシート
        Cells.Clear
End Sub
-----------------------------------------------------------------------------------------
Private Sub ダイアログを表示してフォルダへのパスをセットする()
    絶対パス = Application.GetOpenFilename(Title:=タイトル) 'ダイアログ表示し絶対パス取得
    If 絶対パス <> False Then                   '[キャンセル]でなければ
        For カウンタ = 1 To Len(絶対パス)
            結果 = InStr(カウンタ, 絶対パス, ":", 1) 'テキストモード比較
            If 結果 > 0 Then                    'セパレータが見つかったなら
                文字数 = 結果                   'セパレータまでの文字数としてセットする
            End If
        Next
        親フォルダパス = Left(絶対パス, 文字数) 'フォルダへのパス(ファイル名なし)
        Range("A1").Value = 親フォルダパス
    End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub フォルダ名とサブフォルダ名を取得してシートにセットする()
    貼付行 = 2                                  '貼付用の行カウンタをセット
    取得名 = Dir(親フォルダパス, vbDirectory)   'フォルダ名を取得する
    Do While 取得名 <> "": Debug.Print 取得名
        If 取得名 <> "." And 取得名 <> ".." Then '現在フォルダ、親フォルダでなければ
            If (GetAttr(親フォルダパス & 取得名) And vbDirectory) = vbDirectory Then 'フォルダなら
                Cells(貼付行, 1) = 親フォルダパス & 取得名 & "\" '取得したフォルダへのパス
                貼付行 = 貼付行 + 1
            End If
        End If
        取得名 = Dir                            '次の名前を取得する
    Loop
End Sub
-----------------------------------------------------------------------------------------
Private Sub 各フォルダ中のブック名を取得してシートにセットする()
    貼付行 = 1
    下端行 = Range("A65536").End(xlUp).Row  'フォルダ名シートのデータの下端行番号
    Worksheets("ブック名").Activate         'ブック名をセットするシート
    For カウンタ = 1 To 下端行
        作業フォルダパス = Worksheets("フォルダ名").Range("A" & カウンタ).Value
        ブック名 = Dir(作業フォルダパス & 拡張子) 'ブック名を取得する
        Do While ブック名 <> ""
            Cells(貼付行, 1) = 作業フォルダパス
            Cells(貼付行, 2) = ブック名
            貼付行 = 貼付行 + 1
            ブック名 = Dir
        Loop
    Next
    Columns("A:B").EntireColumn.AutoFit
    Range("A1").Select
End Sub
-----------------------------------------------------------------------------------------
Private Sub ブックを順に開いて作業する()
    下端行 = Range("A65536").End(xlUp).Row      'ブック名シートのデータの下端行番号
    For カウンタ = 1 To 下端行
        ブック名 = Worksheets("ブック名").Range("B" & カウンタ).Value
        開くフォルダパス = Worksheets("ブック名").Range("A" & カウンタ).Value
        絶対パス = 開くフォルダパス & ブック名
        Workbooks.Open Filename:=絶対パス       'ブックを開く
        開いたブックに共通処理をする            '★★
        ActiveWorkbook.Save                     '上書き保存する
        ActiveWorkbook.Close                    '閉じる
    Next
End Sub
-----------------------------------------------------------------------------------------
Private Sub 開いたブックに共通処理をする()
    MsgBox "開きました", , "Excelマクロ組み方講座" '★★ ここで必要な処理をする ★★
End Sub
=========================================================================================
 Copyright(C)2002 HappyTech & Co., Ltd.(Yoshioh Nagai)
=========================================================================================