'=========================================================================================
' すぐに役立つエクセルVBAマクロ集 同項目を1行に並べる ★ Copyright(c)1998 Yoshioh Nagai ★
'=========================================================================================
Option Explicit
Dim 下端 As Integer                             'シートの下端セルの行番号
Dim 貼付行 As Integer                           '貼り付ける行のカウンター
Dim 連結下端 As Integer                         '連結シートのデータの下端行
Dim 読取行 As Integer                           '連結シートのデータを読み取る行カウンタ
Dim はじめ As Integer                           'マクロ実行が始まった最初だけ:0
Dim 列 As Integer                              '並べるシートにデータを貼り付ける列カウンタ
'-----------------------------------------------------------------------------------------
Sub 同項目のデータを1行に並べる()
    Sheets("連結").Select                       '連結シートを選ぶ
        Cells.Clear                             'すべてクリア
'
    Sheets("表1").Select                        '元データのシートを選ぶ（1枚目）
        下端 = Range("A1").End(xlDown).Row      '下端検出
        Range(Cells(1, 1), Cells(下端, 2)).Copy '検出した範囲を選択してコピー
    Sheets("連結").Select
        Range("A1").PasteSpecial Paste:=xlAll   'すべて貼り付け
        貼付行 = 下端 + 1                       '次に貼り付けるための行
'
    Sheets("表2").Select                        '元データのシートを選ぶ（2枚目）
        下端 = Range("A1").End(xlDown).Row
        Range(Cells(1, 1), Cells(下端, 2)).Copy
    Sheets("連結").Select
        Range(Cells(貼付行, 1), Cells(貼付行, 1)).PasteSpecial Paste:=xlAll
        連結下端 = 貼付行 + 下端                '張付け終った最下行
'
        Range("A1").Select
            Selection.SortSpecial SortMethod:=xlSyllabary, Key1:=Range("A1"), _
            Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom '昇順にソートする
'
    Sheets("並べる").Select                     '1行に並べるシートを選ぶ
        Cells.Clear                             'すべてクリア
        貼付行 = 0                        'データを貼り付けるための行カウンターを初期化
        はじめ = 0                              'マクロ実行が始まった最初だから:0
        For 読取行 = 1 To 連結下端              '連結シートの1行目から最下行まで
            If はじめ = 0 Then                  'マクロ実行が始まった最初なら
                はじめ = 1                      'ここを1度通過したしるしとして1に変える
新項目の処理:
                列 = 2                          'データをB列から並べるため
                貼付行 = 貼付行 + 1             '貼り付け行カウンターを1行上げる
                Cells(貼付行, 1) = Sheets("連結").Cells(読取行, 1).Value '項目名を写す
            End If
            If Cells(貼付行, 1) <> Sheets("連結").Cells(読取行, 1).Value Then
                                                '前の項目名と違うなら
                GoTo 新項目の処理               '新しい項目名の処理へ行く
            Else                                '項目名が同じなら
                Cells(貼付行, 列) = Sheets("連結").Cells(読取行, 2).Value 'データを写す
                列 = 列 + 1                     '貼り付け列カウンターを1列上げる
            End If
        Next                                    '繰り返す
End Sub
'=========================================================================================
'          ★ 同項目のデータを1行に並べる ★         V1.0                  (C)1998.12.5
'=========================================================================================