http://q.hatena.ne.jp/1205765249

質問者さんのシート、これはシフト管理をするものなのかな？

左側のシートは、

「ある日のある人がどの当番に入っているか」

がわかる表で、これを、

「ある日のある当番が誰なのか」

を一覧にしたものが右側のシート、
と思われます。

質問者さんの左側のシート、1行目の数字が何を意味してるのかは
わかりませんが、日付としてみます。
2行目は曜日のようですが、これは右側のシートに出てきていませんので、
ここでは無視します。

とりあえず、5日までダミーで作ってたのがこちら。

これを右側の形に直すVBAを作ってみます。

まず、日付と思われる数字をいれちゃいます。
このシートでは5日までですが、何日まで入っているかわからないので、
1行目がどの列までデータが入っているかを調べてみます。

いつもは、縦（下）方向にデータが最後に入っている行を探していましたが、
今度は横（右）方向に調べてみます。

いつもの下方向は、
ActiveSheet.Range(“A1″).End(xlDown).Select
lastgyou = ActiveCell.Row
こんな感じ。

XlDownってなってるところが、下方向に探すところかな？
これを変えれば、右方向に探してくれると思うので、なんて変えればいいかを
調べてみます。
xlDown 右方向　で検索すると、
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_cell.html#xlup
のページが見つかりました。

xlToRightでいいみたいですね。

いつもはA1から下に調べていますが、今回は、B1から右に調べます。

Sub test()
    Dim lastretu As Integer
    Dim i As Integer

    Sheets("Sheet1").Select
    ActiveSheet.Range("B1").End(xlToRight).Select
    lastretu = ActiveCell.Column

    For i = 2 To lastretu
        Debug.Print (ActiveSheet.Cells(1, i).Value)
    Next

End Sub

lastretuという変数に、最終列が何列目かを入れるようにしました。

いつもの、
lastgyou = ActiveCell.Row

が

lastretu = ActiveCell.Column

となっています。アクティブのセルの列番号を取ってきています。

実行してみると、

ん、いい感じ(^^)

とりあえず、この値を結果のシートに入れちゃいます。

入れる場所なんですけど、列はAでいいんですが、行は何行目になるかを
計算しないといけないですね。

For ループで、iは2からlastretuまで変化します。

i=2の時（B2の時、つまり日付が1の時）、この「1」という日付の値をコピーする先は
Sheet2の2行目になります。

i=3の時（B3の時、つまり日付が2の時）、この「2」という日付の値をコピーする先は
Sheet2の5行目になります。

なんで5行目になるかですが、質問者さんが「各当番は最高３人まで」と書いていますので、
1日である当番の値は最大3行分です。というわけで、3行分開けた5行目が2列目の最初になります。

同じように
i=4の時、Sheet2の8行目、
i=5の時、Sheet2の11行目、
・
・
・
i=xの時、Sheet2の(x-2)*3+2 行目ですね(^^;)
Sheet2が結果のシートだとして、縦に入れていきます。

Sub test()
    Dim lastretu As Integer
    Dim i As Integer
    Dim copydata As String

    '1行目の最終列を求めます
    Sheets("Sheet1").Select
    ActiveSheet.Range("B1").End(xlToRight).Select
    lastretu = ActiveCell.Column

    '日付をコピーします
    For i = 2 To lastretu
    'コピーするデータをcopydataという変数に入れます。
        Sheets("Sheet1").Select
        copydata = ActiveSheet.Cells(1, i).Value
    'Sheet2にデータをコピーします。
        Sheets("Sheet2").Select
        ActiveSheet.Cells((i - 2) * 3 + 2, 1).Value = copydata
    Next

End Sub

コメントを入れてみました。copydataという変数を設けて、Sheet1から1つずつ抜き出して、Sheet2の該当するセルにコピーしていきます。

実行してみると、

ん、できてます(^^)

で、次。
Sheet1をAさんからIさんまで順番にSheet2にコピーしていきたいと思います。

まず、AさんからIさんまでを抜き出してみます。
これはいつもどおりですね。

Sub test()
    Dim lastretu As Integer
    Dim lastgyou As Integer
    Dim i As Integer
    Dim copydata As String

    '1行目の最終列を求めます
    Sheets("Sheet1").Select
    ActiveSheet.Range("B1").End(xlToRight).Select
    lastretu = ActiveCell.Column
    '最後の人を求めます
    ActiveSheet.Range("A3").End(xlDown).Select
    lastgyou = ActiveCell.Row

    '日付をコピーします
    For i = 2 To lastretu
    'コピーするデータをcopydataという変数に入れます。
    Sheets("Sheet1").Select
        copydata = ActiveSheet.Cells(1, i).Value
    'Sheet2にデータをコピーします。
    Sheets("Sheet2").Select
        ActiveSheet.Cells((i - 2) * 3 + 2, 1).Value = copydata
    Next

    '最初の人から最後の人まで表示します。
    Sheets("Sheet1").Select
    For i = 3 To lastgyou
        Debug.Print (ActiveSheet.Cells(i, 1).Value)
    Next

End Sub

実行してみます。

ん、全員出ました(^^)

では、それぞれの人の当番を抜き出してみます。
これは先ほど見つけたlastretuの値を使って、抜き出せますね。

Sub test()
    Dim lastretu As Integer
    Dim lastgyou As Integer
    Dim i As Integer
    Dim j As Integer
    Dim copydata As String

    '1行目の最終列を求めます
    Sheets("Sheet1").Select
    ActiveSheet.Range("B1").End(xlToRight).Select
    lastretu = ActiveCell.Column

    ActiveSheet.Range("A3").End(xlDown).Select
    lastgyou = ActiveCell.Row

    '日付をコピーします
    For i = 2 To lastretu
    'コピーするデータをcopydataという変数に入れます。
    Sheets("Sheet1").Select
        copydata = ActiveSheet.Cells(1, i).Value
    'Sheet2にデータをコピーします。
    Sheets("Sheet2").Select
        ActiveSheet.Cells((i - 2) * 3 + 2, 1).Value = copydata
    Next

    '最初の人から最後の人まで表示します。
    Sheets("Sheet1").Select
    For i = 3 To lastgyou
        Debug.Print (ActiveSheet.Cells(i, 1).Value)
        '各個人の当番を抜き出します。
        For j=2 to lastretu
                Debug.Print (ActiveSheet.Cells(i, j).Value)
        Next
    Next
End Sub

jの変数でループしています。
実行すると、

ん、Hさん、Iさんしか見えませんが、抜き出せていますね(^^)

これで、

いつ（jの値でわかります）、
誰が(iの値でわかります)、
何の当番か（Cells(i, j)のセルの値でわかります）

を、全てのセルに対して抜き出すことが出来ましたので、
上の値を使って、今度はSheet2にその情報を書き出していきます。

とはいえ、Sheet2のどこに何を書き出すのかは、単純な計算式などでは求まりません。
この部分のアルゴリズムがこのプログラムの肝になりそうです。

試しに、Aさんの情報を手動で、Sheet2に書き出す手順を考えていきます。

まず、Aさんの1日、これは「早番」です。

Sheet2は最初、

こんな状態です。
1行目には、当番を書きます。今回は「早番」を抜き出してきたので、
B1のセルに「早番」と入れます。

で、1日の「早番」はAさんである、という情報は、B2のセルに表現します。

とりあえず、これで1つ目の処理は終わりですね。

次、今度はAさんの2日について。今度は「遅番」です。
Sheet2の1行目に今度は「遅番」という情報を追加します。
C1のセルになりますね。

で、2日の「遅番」はAさんである、これは、C5のセルに表現します。

こんな感じ(^^)

次、Aさんの3日について。今度は「早番」です。
早番は、さっき1日の時に、B列に作っちゃいましたので、1行目は
何もしません。
で、3日の「早番」はAさんである、これは、C8のセルに表現します。

次、Aさんの4日について。今度は「普通」です。
これは今までには出てきていない当番なので、1行目に増やさないといけないですね。
3つ目の当番ですので、D1のセルになります。

で、4日の「普通」はAさんである、これは、D11のセルに表現します。

次、Aさんの5日について。「遅番」ですので、これはもうCの列に作ってあります。
5日の「遅番」はAさんである、これは、C14のセルに表現します。

これでAさんの情報は表示が終了しました。

同じようにBさん、Cさん・・・最後のIさんまでやっていきます。
さて、まず1行目の当番について。
これは抜き出したデータの当番が新しいものだったら（すでに出ている当番でなければ）、
どんどん右へ追加していく形でよいと思います。

どこに情報を出すのかを決める際、列は

・すでに出ている当番の場合は、その列に。
・今までに出ていない当番の場合は、最後の列に追加して、その列に。

で決めることが出来ます。

行は、どこになるでしょうか？
今、Aさんの情報を抜き出してきた時は、Aさんははじめの人ですから、
1日は2行目、
2日は5行目、
3日は8行目、
4日は11行目、
5日は14行目
と、すんなり書き出せましたけど、、、。

試しにBさんもやってみます。

Bさんの1日の当番は「遅番」です。列は、すでにC列にありますから追加する必要はありません。
で、1日の「遅番」はBさんである、これはC2のセルに表現します。

次、Bさんの2日の当番も「遅番」です。C列に書き出しますが、
2日はAさんも「遅番」です。
ということは、C5のセルはすでにAさんが入っていますから、その下に書き出さなければ
なりません。C6に入ることになります。

こんな感じですね。

ということで、抜き出した情報をどこに出すかですが、
・まず、当番の値で列を決める(今の例だと、Ｃ列)。
・その列で、何日目かにより、基準となる行を求める（今の例だと、5行目）。
・その列と行のセルに値が入っていなければ、そこに書き出す。入っていたら、その下を見る。
　その下も入っていたら、さらにその下を見る、以下繰り返し。

って感じですね(^^;)

プログラムにしてみます。

Sub test()
    Dim lastretu As Integer
    Dim lastgyou As Integer
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim copydata As String

    Dim nukidashihito As String
    Dim nukidashitouban As String

    Dim kakidashiretu As Integer
    Dim kakidashigyou As Integer

    'Sheet2をすべて空にしておきます。
    Worksheets("Sheet2").Cells.Clear

    '1行目の最終列を求めます
    Sheets("Sheet1").Select
    ActiveSheet.Range("B1").End(xlToRight).Select
    lastretu = ActiveCell.Column

    '一番最後の人を求めます
    ActiveSheet.Range("A3").End(xlDown).Select
    lastgyou = ActiveCell.Row

    '日付をコピーします
    For i = 2 To lastretu

    'コピーするデータをcopydataという変数に入れます。
        Sheets("Sheet1").Select
        copydata = ActiveSheet.Cells(1, i).Value

    'Sheet2にデータをコピーします。
        Sheets("Sheet2").Select
        ActiveSheet.Cells((i - 2) * 3 + 2, 1).Value = copydata
    Next

    '最初の人から最後の人まで抜き出します。
    For i = 3 To lastgyou

        '今から処理する人の名前をnukidashihitoに入れます
        Sheets("Sheet1").Select
        nukidashihito = ActiveSheet.Cells(i, 1).Value

    '各個人の当番を抜き出します。
    'jは2列目から最後の列までを表しています。
    For j = 2 To lastretu

            'その人のその日付の当番を nukidashitoubanに入れます。
            Sheets("Sheet1").Select
            nukidashitouban = ActiveSheet.Cells(i, j).Value

            'nukidashitoubanの値から、どこの列に書き出すかを求めます。
            'Sheet2をB1から右に見ていき、すでにあれば、その列に
            'なければ､そのnukidashitoubanの値を追加して､その列にします｡
            Sheets("Sheet2").Select

            '書き出す列をＢ列（右から2つめの列）から探します。
            kakidashiretu = 2

            Do
                'もし、すでにその列に同じ当番があったら、ループを抜ける
                If ActiveSheet.Cells(1, kakidashiretu).Value = nukidashitouban Then Exit Do

                'もし、何も書かれていないセルだった場合、新しい当番なので、
                'そのセルにnukidashitoubanの値を入れ、ループを抜ける
                If ActiveSheet.Cells(1, kakidashiretu).Value = "" Then
                    ActiveSheet.Cells(1, kakidashiretu).Value = nukidashitouban
                    Exit Do
                End If

                '１つ右のセルを調べる
                kakidashiretu = kakidashiretu + 1

            Loop


            '何日目の情報を抜き出しているか( j の値・・・2～lastretuまで変化します)によって、書き出すセルの基準の行を決めます。
            kakidashigyou = (j - 2) * 3 + 2

            '書き出す基準となったセルを含めて、下に3つ分のセルの中から、開いている
            'セルに値を代入します。どこも開いていなければ、何もしません

            For k = kakidashigyou To kakidashigyou + 2

                If ActiveSheet.Cells(k, kakidashiretu).Value = "" Then
                    ActiveSheet.Cells(k, kakidashiretu).Value = nukidashihito

                    Exit For
                End If

            Next

    Next

    Next

End Sub

一気に長くなっちゃいました(^^;)
まず、全ての処理を行う前に、Sheet2を空にしておきます。
赤い部分で、書き出す列を決めています。kakidashiretu を２から調べていき、
赤い部分を抜けた段階で、書き出す列の値がkakidashiretu に入っていることになります。

青い部分で、書き出す行を決めています。
Sheet1の列（ j ）の値を使って、まず基準となる行をkakidashigyouに入れます。
その後で、まず、kakidashigyou行目を見て、そこに値が入っていなければ、そこに当番の人を
書き込みます。For のループで、下2つ分で見つかるまで繰り返しています。

実行してみると、

いいんでないかい(^^)

これで一応完成かな？

Sheet1に入っている値によっては、問題が出る場合もあります。
例えば、「当番は3人まで」という条件以外のデータが入っていたりすると、4人目以降の人の情報は出ません。

また、例えば当番のない人（休みとか？）の場合、当番の値を空にするかもしれませんが、
その場合も正しく値が代入されません。

人数が増えても、当番の種類が増えても、このままのプログラムで問題ないですが、
「一日最大３人まで」の条件が変わる場合は、何箇所か手を入れる必要があります。
セルを求める式の掛け算の3の値と、最後のFor の K のTo のところの+2を変えれば、
大丈夫だと思います。

とりあえず、ここにおいておきます→vbastudy_0009.xls