パスワードを忘れた? アカウント作成
13987193 journal
日記

patagonの日記: [コンピュータ]フォルダ内の各Excelブックのシート「sheet1」をまとめるマクロ(VBA) 3

日記 by patagon

AAA.xlsx (Sheet1)
  見出し1,見出し2,見出し3
  1,A,X
  2,B,Y

CCC.xlsx (Sheet1)
  見出し1,見出し2,見出し3
  1,C,K
  2,D,L
  3,E,M

FFF.xlsx (Sheet1)
  見出し1,見出し2,見出し3
  1,F,O
  2,G,P

というようなExcelの各Sheet1を
以下のマクロを保存しているSample1.xlsmを実行すると
Sample1.xlsmのSheet1に以下のようにデータを作る。

Sample1.xlsm (Sheet1)
  見出し1,見出し2,見出し3
  1,A,X
  2,B,Y
  1,C,K
  2,D,L
  3,E,M
  1,F,O
  2,G,P

Sub フォルダ内のExcelブックのシートをまとめる()
    '機能:各Excelブック内のsheet(1)をこのExcelブックのsheet(1)にまとめる
    '前提:各Excelブック内のsheet(1)がActiveであること
    '参考:http://moritahyoukeisan.com/excel48/pagev13/pagev13.htm
 
    '処理速度を速くする
    Application.ScreenUpdating = False  '画面の表示更新を止める
    Application.DisplayAlerts = False   '警告の表示更新を止める
 
    Dim KihonColumn  As Integer
    Dim myPath       As String
    Dim myFname1     As String
    Dim myFname2     As String
 
    Dim i            As Long
    Dim lastRw       As Long   '各Excelブック シートの最終行
    Dim lastRwnewbk  As Long   '統合の際の最終行
 
    '基本となる列(統合の際、最終行を取得する列)を設定する
    KihonColumn = 1
 
    '変数取得および設定
    myPath = ThisWorkbook.Path                 'マクロの入ったExcelブック(自分自身)のパスを取得
    myFname1 = Dir(myPath & "\" & "*.xls*")    '同フォルダ(同パス)のExcelブックのファイル名をひとつ取得
 
    '自分自身(のシート)をクリアする
    ThisWorkbook.sheets(1).Cells.Clear
 
    'ヘッダーをつける
    '自分以外のExcelブックをひとつ開く
    If myFname1 = ThisWorkbook.Name Then     'もし自分(=マクロの入ったブック)と同じファイル名だったら
        myFname1 = Dir()                     'もう1回ファイル名を取得
    End If
 
    With Workbooks.Open(myPath & "\" & myFname1)    '上で取得した自分以外のExcelブックを開いて、アクティブにする
            .Activate
    End With
 
    '隠れた列を見せる
    ActiveWorkbook.Sheets(1).Columns.Hidden = False
    'コピー&ペースト
    ActiveWorkbook.Sheets(1).Rows(1).Copy _
        Destination:=ThisWorkbook.Sheets(1).Cells(1, 1)    '1行目(ヘッダー行)をコピーする
 
    ActiveWorkbook.Close False
 
    'もう一度ファイル名を取得する
    myFname2 = Dir(myPath & "\" & "*.xls*")
 
    'ブックを順次開いてコピー&ペーストする
    Do Until myFname2 = ""
        If myFname2 = ThisWorkbook.Name Then    '自分と同じファイル名のときは何もしない
        Else
            With Workbooks.Open(myPath & "\" & myFname2)
                    .Activate
            End With
 
            '隠れた列を見せます
            ActiveWorkbook.Sheets(1).Columns.Hidden = False
 
            'フィルタがもしかかっていたら、全セル見せる
            If ActiveWorkbook.Sheets(1).FilterMode = True Then
                ActiveWorkbook.Sheets(1).ShowAllData
            End If
 
            lastRwnewbk = ThisWorkbook.Sheets(1).Cells(Rows.Count, KihonColumn).End(xlUp).Row    'コピー先Excelブック(統合後のブック)シートの最終行を取得
 
            lastRw = ActiveWorkbook.Sheets(1).Cells(Rows.Count, KihonColumn).End(xlUp).Row       '各Excelブック シートの最終行を取得
 
            'コピー&ペースト
            If lastRw = 1 Then  '最終行が1のとき(=ヘッダーしかないとき)はなにもしない
            Else
                ActiveWorkbook.Sheets(1).Range(Rows(2), Rows(lastRw)).Copy _
                    Destination:=ThisWorkbook.Sheets(1).Cells((lastRwnewbk + 1), 1)    '2行目から取得した最終行までをコピーし貼り付ける
 
                i = i + (lastRw - 1)    '件数を数える
 
            End If
 
            ActiveWorkbook.Close False  '開いたExcelブックを保存しないで閉じる
 
        End If
 
        myFname2 = Dir()    '次のExcelブックのファイル名を取得
 
    Loop
 
    ActiveSheet.Range("A1").AutoFilter  '設定 or 解除
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 
    ThisWorkbook.Activate
    MsgBox "全部で " & i & " 件です"
 
End Sub

typodupeerror

コンピュータは旧約聖書の神に似ている、規則は多く、慈悲は無い -- Joseph Campbell

読み込み中...