質問番号：1418054103
ExcelのA-AY列において、同一コードを持つ行を結合させたいです。ただ、P列からT列は除外し、同一コードの行の結合がAY列まで終了次第、直下に1行追加→P-T列は追加された行の各セルに、数値の合計を計算。→その動作を1500行ぐらい繰り返したいのですが。
そんなマクロって、可能でしょうか？
今、D列に、図のようなデータが並んでおります。（1）まず、100、200、300、400…とありますが、それぞれ同じデータがセルにあれば1つに結合します。
（2）そしてそれを水平展開し、他の列もD列と同じように結合していきます。（P-T列を除く）
1つのコードに対応する結合データが、AYまでの全ての列で展開できましたら。
（3）1行挿入し、P-T列のデータをこの http://f.st-hatena.com/images/fotolife/m/moon-fondu/20141209/20141209005013.jpg?1418053841 ように、隣接する結合セルの範囲毎に集計。（1）に戻り、1500行の所まで繰り返す…といった処理をマクロで行いたいのですが。
もし、複雑になりすぎるようでしたら、結合→1行挿入の繰り返しだけでも構いません。
サンプルファイルはこちら http://xfs.jp/LMPmT に置きました。
お力添えをいただければ幸いです。よろしくお願い致します。
質問内容（セルの結合部分）がイマイチ不明な為、一部の列のみを結合したソースコードを書いてみた。
（他の列を結合させたい場合は、結合させたい列分だけコードを追加すればOK）
Option Explicit
Sub main()
Dim lp As Long ' カウンタ
Dim LastRow As Integer ' 最終行
Dim RowCount As Long ' 結合・合計するセル行数
' セルマージ時に出るメッセージをブロック
Application.DisplayAlerts = False
' サンプルシートをコピー
If Worksheets.count = 1 Then
Worksheets(1).Copy After:=Sheets(1)
End If
RowCount = 1 ' 結合・合計行カウントセット
' コピーしたシートで処理
With Worksheets(2)
LastRow = .Cells(Rows.count, 1).End(xlUp).Row + 1 ' 最終行
lp = 2 ' 1行目は見出し
' 最終行まで処理
Do
' D列セルと直後のD列セルを比較。 違っていたら合計用の行挿入及び合計をセルにセット
If .Range("D" & lp) <> .Range("D" & lp + 1) Then
' 合計行挿入
.Range(lp + 1 & ":" & lp + 1).Insert
' P列にセル行数、Q〜T列に合計をセット
.Range("P" & lp + 1) = RowCount
.Range("Q" & lp + 1) = WorksheetFunction.Sum(.Range("Q" & lp - RowCount + 1 & ":" & "Q" & lp))
.Range("R" & lp + 1) = WorksheetFunction.Sum(.Range("R" & lp - RowCount + 1 & ":" & "R" & lp))
.Range("S" & lp + 1) = WorksheetFunction.Sum(.Range("S" & lp - RowCount + 1 & ":" & "S" & lp))
.Range("T" & lp + 1) = WorksheetFunction.Sum(.Range("T" & lp - RowCount + 1 & ":" & "T" & lp))
.Range("P" & lp + 1 & ":" & "T" & lp + 1).Font.Color = vbRed
' セルの結合（とりあえずB列とD列のみ C列とE列のセルにcountif関数が入っている為、セル結合後計算結果が変わる）
.Range("B" & lp - RowCount + 1 & ":" & "B" & lp).Merge
.Range("D" & lp - RowCount + 1 & ":" & "D" & lp).Merge
LastRow = LastRow + 1 ' 合計行（1行）を追加
lp = lp + 2 ' 合計行＋次行移動
RowCount = 1 ' 結合・合計行カウントセット
Else
RowCount = RowCount + 1 ' 結合・合計行カウントアップ
lp = lp + 1 ' 次行移動
End If
Loop While lp + 1 <= LastRow
End With
End Sub
