値別にシートに分割する処理
「リスト」というシートのA列に担当者が並んでいます。
担当者ごとにシートに切り分けて集約させるプログラムを書いてみます。
方針
まず、A列を巡回して担当者名を持つシートを作っていきます。
この時、同じ担当者名が来た場合はシートは作りません。
次に、もう一度「リスト」シートのA列を巡回して、担当者と同じ名前のシートの最後に値を追加するようにします。
自分でイチから作る場合は、シートを追加していく処理、値をコピーしていく処理と、段階を分けて完成させていった方が、早い段階でミスに気づくことができるのでお勧めの方法です。
ソースコード
Sub 分割シート作成()
Dim ws As Worksheet
Dim newWs As Worksheet
Dim lastRow As Long
Dim r As Long, i As Long, flag As Boolean
Set ws = Worksheets("リスト")
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row '①
For r = 2 To lastRow
flag = False '②
For i = 1 To Worksheets.Count '③
If Worksheets(i).Name = ws.Cells(r, "A").Value Then '④
flag = True
Exit For
End If
Next i
If flag = False Then '⑤
Set newWs = Worksheets.Add(After:=Worksheets(Worksheets.Count))
newWs.Name = ws.Cells(r, "A").Value
End If
Next r
For i = 1 To Worksheets.Count '⑥
With Worksheets(i)
If Worksheets(i).Name <> "リスト" Then
.Cells.Clear 'それまでの値をクリアする。 ⑦
End If
For r = 2 To lastRow '⑧
If .Name = ws.Cells(r, "A").Value Then
Dim csLastRow As Long
csLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
ws.Cells(r, "A").EntireRow.Copy .Cells(csLastRow + 1, "A") '⑨
End If
Next r
End With
Next i
End Subプログラム解説
①で最初に「リスト」シートの最終行を得てForループを組みます。
②の flag というブーリアン型の変数は、担当者名が初めて出てきたかを検出するための変数になります。
③でワークシート名と「リスト」シート内の値を比較して、もし既に値と同じシート名があれば、
flag = True として処理を抜けます。
もし最後まで、名前が一致しなければ、シートを作ることになります。
⑤は、シートを新たに追加する処理です。
ここまでの処理で、担当者別のシートが重複なく作成されます。
次は、これらのシートに値をセットしていく処理です。
今回は⑥のようにシート毎に巡回するループが先に来ます。
一つのシートに対して、最初の段階で値が既にあればクリアするようにしています。⑦
これは、2回目の実行などで既にシートに値が入っている場合を想定しています。
（この処理が無い場合、2回目の実行では値が下に追加されてしまいます。）
⑧は「リスト」シート内のループです。
A列の値が一致した場合、同じ名前のシートに値を追加します。
この時、毎回最終行を取得する必要があります。
⑨で該当する値をコピーして貼り付けています。
まとめ
リストの項目別にシートを切り分けて集約させるような処理は業務改善などでよく行われる処理だと思います。
今回のようなプログラムを自力で作れるようになれば、初心者を卒業したと言っていいでしょう。
例に挙げたプログラムが唯一の正解という事はありません。
自分のやり方でプログラムを組み立てるには丁度良い課題だと思いますので、是非挑戦してみてください。
今回のプログラムのポイントをまとめておきます。
ポイント
・今回のような場面では、Forループは必ず二重構造となります。
・「シートを追加する処理」「値をコピーする処理」のように段階に分けてプログラムを組むと分かり易くなります。
・重複させたくない処理では、今回のようにフラグを使う方法や、リスト化、辞書などを使う方法があります。
・2回実行された時に、結果がおかしくならないような配慮が必要になります。
コメント