ド素人でも学べる ExcelVBA 014 シート集計

はじめに

　ExcelVBAでは、ワークシートを Worksheets というオブジェクトの配列（コレクション）で扱っている。
これは前回のページで紹介した。

　配列は、一旦作ると要素数を変化出来ないものと、可変できるものがある。Worksheets のようなコレクションでは要素数を増減できる。 操作としては、追加、削除、コピー、移動などが可能だ。

　尚、この中で最も使う頻度が多いのは、シートをコピーする操作だと思う。また。シート削除のコマンドは確認ダイアログが出るのが特徴だ。（もちろんダイアログを出さないようにすることも可能。）
　それらのコマンドの詳しい使い方については以下のページを参照してほしい。

　ここでは、以下のような Data シートから、別シートに担当者ごとの値を取りだすプログラムを書いてみる。

準備

　まずは、データシート(data)を以下のように用意してほしい。データ内容に関しては適当に変更しても構わないが、項目と列の関係は崩さないでほしい。

　次に原本というシートを作る。これは集計用のシートとなるが、担当者用のシートの原本になる。
この原本シートをコピーして追加し、担当者のシート名を付けて管理していく考えだ。

　プログラムで集計を行うと以下のように担当者の名前でシートが作成され値が抽出されるようにする。

プログラミング

　最終的には全ての担当者のシートを用意して集計しようと思うが、最初から色々な機能を盛り込んでいくのは得策とは言えない。
　複雑な処理を行う場合は、なるべく単純な処理に切り分けて、成功してから次の処理を付け加えていくようにした方が良い。こうする事でバグなどの不具合に気づきやすくなり修正も楽になるからだ。

　今回の場合は、担当者「山田」さんのみ値を抽出してみよう。最初は予め原本シートをコピーしてシート名を「山田」としておく。この状態からデータを抽出して、プログラムが完成したら拡張していくことにする。

プログラムの方針

　今回のプログラムは、data シートと 山田 シートの使い分けが必要になるので、それぞれを変数にして扱うようにする。（山田 シートは原本シートをコピーして作っておく。）

　最終行の取得方法は以前やったので、今回も使っていく。（よく使う方法なので使えるようにしておこう。）今回は、data シートの最終行を取得して開始行の２行目からループさせる。

　抽出に関しては、D列の担当が「山田」だった時に、その行のA～C列をコピーして、山田シートに貼り付ける。貼り付け先は、row という変数でカウントしていく。

　プログラムは以下のようになる。

Sub 集計macro1()
    Dim dataSh As Worksheet
    Dim sh As Worksheet
    
    Set dataSh = Worksheets("data")
    Set sh = Worksheets("山田")
    
    Dim i As Long
    Dim lastRow As Long
    Dim row As Long
    
    '前回までの値が残っていればクリア
    lastRow = sh.Cells(Rows.Count, "A").End(xlUp).row
    If lastRow > 3 Then
        sh.Range("A4:C" & lastRow).Clear
    End If
    
    'data シートのA列最終行を取得
    lastRow = dataSh.Cells(Rows.Count, "A").End(xlUp).row
    row = 4
    
    '値を抽出
    For i = 2 To lastRow
        If dataSh.Cells(i, "D") = "山田" Then
            dataSh.Range("A" & i & ":C" & i).Copy
            sh.Cells(row, "A").PasteSpecial Paste:=xlPasteAll
            row = row + 1
        End If
    Next i
End Sub

　最初に、data シートと 山田 シートの変数をそれぞれ dataSh , sh として worksheet 型の変数としてゼ宣言している。
　次に Set を付けてワークシートを変数に代入している。このようにオブジェクトを変数に代入する場合は Set が必要になる。（これは忘れやすいので注意してほしい。）
　同じように Range や Workbook なども Set を付けなければいけない。

　さて、ここからは、Range や Cells にワークシート指定をしてから使用しなければいけない。もし、何も付けない場合はアクティブシートが対象となるわけだが、今回の場合は、ユーザーがどのシートをアクティブにしているかの保障はない。

以前の値をクリアする処理

　まず最初に前回までの値があればクリアする処理を行う。初回であれば問題ないが２回目以降、data シートの値が変更になる場合もあるので、以前の値を一旦クリアするようにする。

    '前回までの値が残っていればクリア
    lastRow = sh.Cells(Rows.Count, "A").End(xlUp).row
    If lastRow > 3 Then
        sh.Range("A4:C" & lastRow).Clear
    End If

　ここでは、lastRow に、sh (山田シート) のA列の最終行を取得している。
もし、最終行が３より少ない場合は、クリアする必要はないので、If文を使っている。

data シートのA列最終行を取得

　続いて data シートのA列最終行を取得している。lastRow は山田シートの最終行を求める際にも使用したが、ここでは使い回している。もう山田シートでは使用しないからだ。

    'data シートのA列最終行を取得
    lastRow = dataSh.Cells(Rows.Count, "A").End(xlUp).row
    row = 4

　最後に row 変数に 4 を代入しているが、これは抽出するシート（山田シート）の入力開始行となる。

値を抽出して転記

　ここからはメインの処理になる。DateシートのD列が「山田」なら、山田シートに値をコピーする。
コピー元と貼り付け先の Cells にシート指定するのを忘れないようにしよう。

    '値を抽出
    For i = 2 To lastRow
        If dataSh.Cells(i, "D") = "山田" Then
            dataSh.Range("A" & i & ":C" & i).Copy
            sh.Cells(row, "A").PasteSpecial Paste:=xlPasteAll
            row = row + 1
        End If
    Next i

　貼り付けは、「全ての値」である xlPasteAll を指定している。 Paste:=xlPasteAll 部分は省略する事も歴るが明示的になるので書いた方が良いだろう。

　最後に忘れずに row を増加させておく。

　実行すると以下のようになるはずだ。

機能を拡張する

　ここまでがうまく行ったら、今度は担当者のシートを追加しながら抽出できるように改造してみよう。
担当者のシートがあれば、該当する担当者シートに、無ければ追加するというようにしてみる。

プログラミング方針

　今度の処理は、やり方が 1通りではない。筆者の思いついた方法を解説していく。
まず、担当者用のシートは、既にある場合とない場合が想定される。既にある場合は、これまでの値をクリアする必要がある。また、担当者シートが無い場合は、新しいシートを原本シートからコピーする必要がある。

　最初の処理では、前回のように担当者シートの値部分をクリアすることにする。担当者シートは、 dataシート と 原本シート以外のシートという事になる。

Sub 集計macro3()
    Dim dataSh As Worksheet
    Dim sh As Worksheet
    
    Set dataSh = Worksheets("data")
    
    Dim i As Long
    Dim lastRow As Long
    Dim row As Long
    
    'シートを全て巡り担当者シートの値をクリアする
    For Each sh In Worksheets
        If sh.Name <> "data" And sh.Name <> "原本" Then
            '前回までの値が残っていればクリア
            lastRow = sh.Cells(Rows.Count, "A").End(xlUp).row
            If lastRow > 3 Then
                sh.Range("A4:C" & lastRow).Clear
            End If
        End If
    Next sh

    '//// この後に処理が続く ////

End Sub

　上のプログラムは担当者シートのクリア部分までの処理となる。
ここでは、For Each sh In Worksheets としてワークシートを全て巡回している。
　内部では、 dataシート と 原本シート以外のシートに対して値をクリアする。担当者シートの値をクリアする処理は前と同じだ。

　続いてデータシートの情報から、まだ作成していない担当者シートを作成する。
やり方としては、ｂ というブール型の変数を用意してフラグとして使い、dataシートにある担当者と同じ名前のシートがあるかを探す。もし担当者と同じ名前のシートが無い場合、If b = False Then の内部に進んで原本シートから担当者名のシートを作る。

    
    'data シートのA列最終行を取得
    lastRow = dataSh.Cells(Rows.Count, "A").End(xlUp).row
    
    'dataシートの担当者分のシートを用意する
    Dim b As Boolean
    For i = 2 To lastRow
        b = False
        For Each sh In Worksheets
            If dataSh.Cells(i, "D") = sh.Name Then
                b = True
                Exit For
            End If
        Next sh
        If b = False Then
            Worksheets("原本").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = dataSh.Cells(i, "D")
            ActiveSheet.Range("B1") = dataSh.Cells(i, "D")
        End If
    Next i

　Worksheets(“原本”).Copy after:=Worksheets(Worksheets.Count) とする事で、シートの最後尾にシートをコピーしてくれる。コピーざれたシートはアクティブになるので、アクティブシートに対して名前の変更と、B1セルに担当者名をセットしている。

　最後に値をコピーして貼り付ける処理だ。

    '値を抽出
    For i = 2 To lastRow
        For Each sh In Worksheets
            If dataSh.Cells(i, "D") = sh.Name Then
                row = sh.Cells(Rows.Count, "A").End(xlUp).row + 1
                dataSh.Range("A" & i & ":C" & i).Copy
                sh.Cells(row, "A").PasteSpecial Paste:=xlPasteAll
                Exit For
            End If
        Next sh
    Next i

　先程と同じように data シートを巡回しながら、内部でワークシートを巡回して該当する担当者シートを見つけて値のコピー＆貼り付けを行っている。
　貼り付けが終われば、内側の巡回は終了していいので Exit For で抜けるようにしている。無くても処理は出来るのだが、無駄な巡回を行う事になる。

　全てまとめると以下のようになる。

Sub 集計macro2()
    Dim dataSh As Worksheet
    Dim sh As Worksheet
    
    Set dataSh = Worksheets("data")
    
    Dim i As Long
    Dim lastRow As Long
    Dim row As Long
    
    'シートを全て巡り担当者シートの値をクリアする
    For Each sh In Worksheets
        If sh.Name <> "data" And sh.Name <> "原本" Then
            '前回までの値が残っていればクリア
            lastRow = sh.Cells(Rows.Count, "A").End(xlUp).row
            If lastRow > 3 Then
                sh.Range("A4:C" & lastRow).Clear
            End If
        End If
    Next sh
    
    'data シートのA列最終行を取得
    lastRow = dataSh.Cells(Rows.Count, "A").End(xlUp).row
    
    'dataシートの担当者分のシートを用意する
    Dim b As Boolean
    For i = 2 To lastRow
        b = False
        For Each sh In Worksheets
            If dataSh.Cells(i, "D") = sh.Name Then
                b = True
                Exit For
            End If
        Next sh
        If b = False Then
            Worksheets("原本").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = dataSh.Cells(i, "D")
            ActiveSheet.Range("B1") = dataSh.Cells(i, "D")
        End If
    Next i
    
    '値を抽出
    For i = 2 To lastRow
        For Each sh In Worksheets
            If dataSh.Cells(i, "D") = sh.Name Then
                row = sh.Cells(Rows.Count, "A").End(xlUp).row + 1
                dataSh.Range("A" & i & ":C" & i).Copy
                sh.Cells(row, "A").PasteSpecial Paste:=xlPasteAll
                Exit For
            End If
        Next sh
    Next i
End Sub

　今回のプログラムは、少々長くなったが大きく分けて３つに分解できる。
・すでにある担当者シートのクリア
・dataシートに無い担当者シートを追加
・担当者シートへのコピー＆貼り付け

　さて、よく見るとdata シートの巡回部分と、ワークシートの巡回部分を２回行っている。この部分は１つにまとめる事ができる。

Sub 集計macro3()
    Dim dataSh As Worksheet
    Dim sh As Worksheet
    
    Set dataSh = Worksheets("data")
    
    Dim i As Long
    Dim lastRow As Long
    Dim row As Long
    
    'シートを全て巡り担当者シートの値をクリアする
    For Each sh In Worksheets
        If sh.Name <> "data" And sh.Name <> "原本" Then
            '前回までの値が残っていればクリア
            lastRow = sh.Cells(Rows.Count, "A").End(xlUp).row
            If lastRow > 3 Then
                sh.Range("A4:C" & lastRow).Clear
            End If
        End If
    Next sh
    
    'data シートのA列最終行を取得
    lastRow = dataSh.Cells(Rows.Count, "A").End(xlUp).row
    
    'dataシートの担当者分のシートが無ければ用意して値をコピーする。
    Dim b As Boolean
    For i = 2 To lastRow
        b = False
        For Each sh In Worksheets
            If dataSh.Cells(i, "D") = sh.Name Then
                '値を抽出
                row = sh.Cells(Rows.Count, "A").End(xlUp).row + 1
                dataSh.Range("A" & i & ":C" & i).Copy
                sh.Cells(row, "A").PasteSpecial Paste:=xlPasteAll
                b = True
                Exit For
            End If
        Next sh
        If b = False Then
            Worksheets("原本").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = dataSh.Cells(i, "D")
            ActiveSheet.Range("B1") = dataSh.Cells(i, "D")
        End If
    Next i
    
End Sub

　巡回する回数が減ることになるので、その分処理速度は速くなる。ただ、今回の方法は詰め込み過ぎな感があるので、後から見ずらくなるかもしれない。集計macro2のプログラムの方がわかりやすいのでメンテナンスはしやすいかもしれない。

　わかりやすさを重視するか、速度を重視するかと言った選択になると思う。

まとめ

　今回は初心者にとっては少々難しく感じるかもしれないが、プログラミングの基本的なエキスが詰まった内容なので、頑張って読み解いてほしい。

　余裕のある人は別の書き方もできると思うのでトライしてみてはいかがだろうか。