氏名一覧表からクラス別表を作成するには?

Question 82.3 Excel VBA Borad (掲示板)より Previous Next
まったくの初心者なので、事例を調べてみれば見るほどパニックになっています。 どなたか、下記の処理について教えて頂けないでしょうか。

A 書式の決まったシート(クラス表)があります。(1クラスごとでそれに所属する人員名は6件しか入力できません。)
B クラス名と所属する人員名の一覧表があります。(クラス名の数と人員名の数は月ごとに変動します。)

Aのクラス表を必要枚数コピーして、クラス表M(1)(2)(3)…を作成し、
Bの一覧表から各クラスごと6名づつ データを書き出したいのですが、どのようにしたらいいでしょうか?
【補足】 ・一覧表は重複を取り除いた、クラス名とそれに対応する氏名の一覧です。
    ・1クラスが6名以上とか12名を超える場合もあります。
    ・人数は月ごとに変動し不特定です。

シートをコピーするとシート名が(1)(2)(3)・・・と変動しますし、どのようにしたらいいでしょうか?
ややこやしくて申し訳ありませんが、よろしくお願いします 。
Answer   Copyright (C) 2007.6.14 永井善王
  【概念図・第1ステップ】
概念図 プログラミングの練習要素をたくさん含んだテーマですね。
本格的にフローチャートを描いて、プロ的に組みたくなりがちですが、ムリしないで、Excelらしく処理することをお勧めします。
具体的には、いっぺんに処理するとゴチャゴチャになり易いので、段階的に区切って処理します。
(データが何十万件とか膨大ならば話は別です。)

1. 6行区切りに編集した一時シートを作成する

左の【概念図・第1ステップ】のように、
一覧表シートのクラス名の変わり目で区切りながら、1クラスが6の倍数行になるように一時シートを作成します。
人数が不足する場合は空行とします。

2. 一時シートからクラス表Mを作成する(※)

 クラス表シート
クラス表M 一時シートの人員名を上から6行コピーして、
クラス表シートの人員名(B2セル)に貼り付けます。


その後、クラス表シートのコピーを作成し、クラス表Mとしてのシート名を設定します。
(※)マクロの中では「クラス別表」と表記してます。

続いて、この処理をクラス表シートの下方向へ繰り返します。 そして、全クラス分の処理ができたら、一時シートを削除してから終わります。 以下にマクロをお示しします。 コードの各行のコメントを読んで理解を深めてください。
Option Explicit
Dim 一時シート, 下端行, 貼付行, 取出行, 余白行, シート番号
'-------------------------------------------------------------------------------
Sub 氏名一覧表からクラス別表を作成する()
    一覧表から同クラス分を取り出して一時シートを作成する
    一時シートから6行ずつコピーしてクラス別表を作成する
    一時シートを削除する
End Sub
'-------------------------------------------------------------------------------
Private Sub 一覧表から同クラス分を取り出して一時シートを作成する()
    Application.ScreenUpdating = False          '画面を更新しない
    Sheets.Add                                  '新シートを挿入(一時シート)
    一時シート = ActiveSheet.Name               '新シートの名前を取得
    下端行 = Worksheets("一覧表").Range("A" & Rows.Count).End(xlUp).Row '下端行取得
    貼付行 = 0                                  '貼付行カウンタをリセット
    For 取出行 = 2 To 下端行
        If 取出行 <> 2 Then                     '1番最初の取り出しでなければ
            If Worksheets(一時シート).Range("A" & 貼付行) _
                <> Worksheets("一覧表").Range("A" & 取出行) Then 'クラス名(さっき:今)
                余白行 = 6 - 貼付行 Mod 6       '6行単位するための余白行数を算出
                貼付行 = 貼付行 + 余白行        '貼付行カウンタを余白行数分アップ
            End If
        End If
        貼付行 = 貼付行 + 1                     '貼付行カウンタを1アップ
        Worksheets("一覧表").Rows(取出行).Copy Destination:= _
            Worksheets(一時シート).Range("A" & 貼付行) '一覧表から一時シートへ1行コピー
    Next
End Sub
'-------------------------------------------------------------------------------
Private Sub 一時シートから6行ずつコピーしてクラス別表を作成する()
    下端行 = Worksheets(一時シート).Range("A" & Rows.Count).End(xlUp).Row
    For 取出行 = 1 To 下端行 Step 6
        If Worksheets(一時シート).Range("A" & 取出行) = "" Then Exit For  'なければ
        Worksheets("クラス表").Range("B2:C7").ClearContents               'クリア
        Worksheets(一時シート).Range("B" & 取出行 & ":" & "B" & 取出行 + 5).Copy
                                                                      '6行コピー
        Worksheets("クラス表").Range("B2").PasteSpecial Paste:=xlValues '値貼り付け
        Worksheets("クラス表").Copy Before:=Worksheets("クラス表")     '新シート作成
        シート番号 = シート番号 + 1                         'シート番号を繰り上げ
        ActiveSheet.Name = "クラス表M(" & シート番号 & ")"  '新シートの名前を設定
    Next
End Sub
'-------------------------------------------------------------------------------
Private Sub 一時シートを削除する()
    Application.DisplayAlerts = False           '警告メッセージを表示しない
    Worksheets(一時シート).Delete               '一時シートを削除
    Application.ScreenUpdating = True           '画面を更新する
End Sub
'-------------------------------------------------------------------------------
仕事の時間がきてしまったので、これで解説を終わりにしますが、サンプルブックにはプロ的に組んだマクロも入れてあります。 書き下ろしですが、探究心の素材くらいにはなるかなと思っています。

サンプルブックのダウンロードは ここをクリック  (YNxv99113_Copy.xls 122KB)
※ 一旦、ブックをハードディスクに保存し、後で改めて開いてから実行してください。

Excel VBA Macro