縦配置の住所録を横配置に直すには?

Question 83.5 Previous Next
はじめまして。マクロ初心者で、はたして以下内容が マクロで出来るものなのかの、見当もつきませんが、 必要に迫られ、ようやくこちらを探し当てた次第です。

 【Sheet1】
Sheet1 Sheet1のリストのA列・B列・C列の3列それぞれには、縦方向に住所録が入力されています。
住所-1から住所-3までの人もいれば住所-4までの人もあり様々ですが、リストの氏名欄(Aさん・Bさん・Cさん)のセルの行頭は必ず揃っています。 また、揃えるために最低2行は間隔がおかれています。

これを下図の形のリストにするには、どのような方法がありますか?
 【Sheet2】
Sheet2
(住所録の登録者数は集計の度に毎回不特定で、変動があります。)
いきなりの質問で大変恐縮ですが、どうかお力をお貸しください。
ご照会 2007.7.25 永井善王
Sheet1からSheet2へコピー貼り付けするマクロを記録してみましたね。
まず、Sheet1のA1:C5セルを選択してコピーし、Sheet2のA1セルを選択して貼り付けます。
次に、Sheet1のA8:C12セルを選択してコピーし、Sheet2のD1セルを選択して貼り付けます。
すると、どんなマクロが出来ましたか。そのマクロをご提示ください。

そして、登録者数の変動に対応するためには、そのマクロをどう改造すればよいのか考えられ、苦労されましたね。
どこが分からなかったか、どこで行き詰ってしまったか、具体的にお知らせください。
ご返事お待ちしています。
記録マクロをお送りします
早速のご丁寧なお返事ありがとうございます。 にもかかわらず、お返事が遅れてしまってすみませんでした。 初心者すぎて、次元の違う質問をしてしまったようで、お恥ずかしいばかりです。
まず、マクロの組み立てや専門用語がまだわからないので、マクロの記録をして 記録したマクロを再現するところまではやってみたのですが、 変動する全ての登録者に対して、その選択範囲をどのように繰り返して いけばいいのか、見当がつきません。
選択の仕方をショートカットキーや行列の入れ替えなどでも試したりもしたのです が、 やはり選択範囲の指定の段階から脱することができませんでした。
もう少し勉強してから、質問するべきでしたのに膨大なデータと納期にさし迫られ 質問してしまいました。本当に申し訳ありませんでした。 不適切な質問でしたら無視してくださって結構です。
Sub 縦配列の住所録を横配列に直すには()

 縦配列の住所録を横配列に直すには Macro
 縦配列の住所録を横配列に直すには 07/26/2007

    Range("A1:C5").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Range("A8:C12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("D1").Select
    ActiveSheet.Paste
End Sub
Answer   Copyright (C) 2007.7.26 永井善王
解決しなければいけない問題として、あなたが押さえてみえる点は、
 A. 「登録者数の変動」つまり、Sheet1 の何行目までデータが存在するか
 B. 「どのように繰り返していけばいいのか」
 C. 「選択の仕方」 ですね。
結論から先にお示しします。
下記は、ご提示くださった記録マクロを改造したもので、Sheet1 をアクティブにしてから実行します。
Sub 縦配列の住所録を横配列に直すには()
    下端行 = Range("A" & Rows.Count).End(xlUp).Row  '(A)
    貼付列 = 1                              'Sheet2の貼り付ける列を示すカウンタ
    For 行 = 1 To 下端行 Step 7             '(B) 1行目から下端行までを7行間隔で反復
        Sheets("Sheet1").Select
            Range("A" & 行 & ":C" & 行 + 4).Select  '(C) AからC列の5行を選択
            Selection.Copy
        Sheets("Sheet2").Select
            Range(Cells(1, 貼付列), Cells(1, 貼付列)).Select
                                            '(C) 1行目の貼り付ける列を選択
            ActiveSheet.Paste
        貼付列 = 貼付列 + 3
    Next
End Sub
記録マクロの6行目と12行目を見比べると、1回目のコピー範囲が A1:C5、 2回目のコピー範囲が A8:C12 であることから、7行間隔で処理すればよいことが分かりますね。 このことが、改造マクロの4行目にある For...Next文の Step 7 とした理由になります。
コードの赤字部分は同様の考え方で理解できますね。(記録マクロの9行目と16行目を見比べると 3列間隔です。)

このマクロの機能は最小限です。「膨大なデータ」ということですが、Sheet2 の列数 (Excel2007は16384、2003は256) を超えて貼り付けようとすると実行時エラーになりますが未対策です。画面のチラつきも未対策です。今後、業務用として何回も使用されるなら、対策しておいた方がよいでしょう。

あなたは真面目に取り組んでみえるようで、きっと時間さえあれば、自力で調べて前進される方でしょうね。
マクロは便利ですから、この機会にガンバって覚えておかれるとよいかと思います。
では、結果をお知らせください。
私の説明と例題が悪かったので
ご回答いただいたばかりか、今後の対策や励ましのお言葉まで頂き、 本当にありがとうございます。 教えていただいたマクロを早速試してみました。
私の説明と例題が悪かったのですが、Sheet1のA・B・C列の 横に並んだ3名が、たまたま住所-3までだった場合は、6行の間隔しかなく、 その場合、それ以降のデータがずれてSheet2に反映されてしまいます。 (場合によっては5行で済んでしまうこともあれば、8行にもなり得ます。)
この反復させる行数が確定されていない(変数)である場合のマクロを ずっと知べているのですが、力不足で解決にいたっていないという状況です。
Answer   Copyright (C) 2007.7.27 永井善王
氏名と住所-1と住所-2の場合があって5行ですね。「8行にもなり得」とは住所-5もあるということでしょうか? 絶対に9行は無いですね。 できることなら Sheet1 を作る段階で、全て7行に統一しておきたいですね。 間隔をおくための2行は要りませんから。
とりあえずは現状肯定で進むとして、いろいろな方法が考えられます。 下記は少々強引ですが、目的は達せられると思いますから参考にしてください。
Sub 縦配列の住所録を横配列に直す()
    Worksheets("Sheet1").Activate
    下端行 = Range("A" & Rows.Count).End(xlUp).Row
    始行 = 1
    終行 = 2
    貼付列 = 1                                  'Sheet2の貼り付ける列を示すカウンタ
    Do Until 終行 > 下端行
        Worksheets("Sheet1").Activate
            For 終行 = 始行 To 下端行 + 5
                If Range("A" & 終行) = "" Then
                    Exit For
                End If
            Next
            For 終行 = 終行 To 下端行 + 5
                If Range("A" & 終行) <> "" Then
                    Exit For
                End If
            Next
            終行 = 終行 - 1
            Range("A" & 始行 & ":C" & 終行).Select
            Selection.Copy
        Worksheets("Sheet2").Activate
            Range(Cells(1, 貼付列), Cells(1, 貼付列)).Select
                                                '(C) 1行目の貼り付ける列を選択
            ActiveSheet.Paste
            貼付列 = 貼付列 + 3
        始行 = 終行 + 1
    Loop
End Sub

Excel VBA Macro