エクセルマクロ/ブック、シートのループ

ブックのループ、シートのループ †

このマクロは †

• エクセルのブックとシートをループさせて必要な情報をひとつのエクセルにまとめるマクロ
• 同一のフォーマットのエクセルブック、シートが大量にある場合の集計に有効。

処理概要 †

1. ウィザードでフォルダを選択。
2. 選択したフォルダの中にあるエクセルブックを順番に開く。
3. 開いたエクセルのすべてのシートをループ。
4. マクロを実行しているエクセルブック（clct_stock.xlsm）にループ先の値をコピーする。

動作確認
エクセル2007

動作させるには †

1. エクセルブックにclct_stock.xlsmという名前をつけて、そのエクセルブックにマクロを保存する。
   
2. マクロの保存方法はエクセルのヘルプを参照。
3. 保存したマクロを実行する。

ソースコード †

Sub clct_stock()

Dim dirPass As String
Dim excelPass As String

Dim fileName As Variant
Dim fileNameCollection As Collection
Set fileNameCollection = New Collection


'フォルダの中にあるエクセルファイルパスを取得-----------------

'フォルダパスの取得
With Application.FileDialog(msofiledialogfolderpicker)
    'ダイアログタイトル名
    .Title = "フォルダ選択"
    '開いた時に表示されるフォルダ
    .InitialFileName = ThisWorkbook.Path

    '選択された場合
    If .Show = True Then
        dirPass = .SelectedItems(1) + "\"
        'ファイル名をfileNameCollectionに追加
        fileName = dir(dirPass + "*.xls", vbNormal)
        Do While fileName <> ""
            fileNameCollection.Add (fileName)
            fileName = dir()
        Loop
    End If
End With



'フォルダの中にあるファイルの数だけループする-----------------

'変数宣言
Dim cpFromSheets As Worksheets
Dim cpFromSheet As Worksheet
Dim cpToSheet As Worksheet
Dim i As Integer
Dim j As Integer

'変数初期化
i = 1
Set cpToSheet = Workbooks("clct_stock.xlsm").Sheets(1)
cpToSheet.Columns(2).NumberFormatLocal = "@"


'フォルダの中にあるファイルの数だけループする
For Each fileName In fileNameCollection

    'Excelブックを開く
    excelPass = dirPass + fileName
    With Workbooks.Open(excelPass)

        'シートがあるだけループする
        For Each cpFromSheet In ActiveWorkbook.Worksheets
            j = 10
            Do Until cpFromSheet.Cells(j, 5).Value = ""
                cpToSheet.Cells(i, 1).Value = cpFromSheet.Cells(j, 5).Value
                cpToSheet.Cells(i, 2).Value = cpFromSheet.Cells(j, 1).Value
                cpToSheet.Cells(i, 3).Value = cpFromSheet.Cells(j, 13).Value
                i = i + 1
                j = j + 1
            Loop
        Next

        'Excelブックを閉じる
        Application.DisplayAlerts = False
        Workbooks(fileName).Close
        Application.DisplayAlerts = True
    End With
Next
 
End Sub

メニュー

リンク

• リンク

最新の10件

rm at