VBA データの整理（表）

質問

またVBAなのですが、教えていただける方、お願い致します。
今回は、さらに複雑でお手上げ状態です。

縦になっている元データを、番号ごとに横にしたいです。
それぞれの番号に、詳細データがありますが、数、内容が異なり、それが縦に並んでいるため、全体が把握しにくいのです。
画像の左側に元のデータを、作り変えたい形式を右側に示しました。

番号は、カタカナ（+数字）です。
カタカナは順番に並んでいるのですが、たまに飛ぶときがあります。
(1)元データD列が◆、あ、▲のとき、番号と◆が交差するところに、番号を入力したいです。このとき、C列は関係ありません。
(2)次に、元データD列が◆、あ、▲以外のもののとき、C列、D列を(1)、(2)、(3)に入れたいのです。
例えば【カ】のように、その種類が3つ以上のものもあり、その時は、2列、3列にして表示したいです。最終的に印刷したいため、紙を横にしたときに、横に入るのが3つまでかなということで、この形式にしています。

理想を添付したのですが、若干異なっても大丈夫ですので、教えて頂けたらありがたいです。
よろしくお願い致します。

回答No.1

SI299792 · ベストアンサー

F1: ◆
G1: あ
H1: ▲
は必ず入れて実行して下さい。

Option Explicit
'
Sub Macro1()
　　Dim ROut As Long
　　Dim RSta As Long
　　Dim COut As Integer
　　Dim RInp As Long
　　Dim NowKey As String
　　Dim OldKey As String
　　Dim Match As Variant
　　Dim Color As Long
'
　　Color = vbWhite
　　Cells.Interior.Pattern = xlNone
　　Cells.UnMerge
　　Range("F2:R" & Rows.Count).ClearContents
　　ROut = 1
　　Application.ScreenUpdating = False
'
　　For RInp = 2 To [A1].End(xlDown).Row
　　　　NowKey = Cells(RInp, "A") & Cells(RInp, "B")
'
　　　　If OldKey <> NowKey Then
　　　　　　Color = Color Xor rgbPeachPuff Xor vbWhite
　　　　　　[F1:R1].Offset(ROut).Interior.Color = Color
　　　　　　[I1:J1].Offset(ROut) = Cells(RInp, "A").Resize(, 2).Value
　　　　　　[Q1:R1].Offset(ROut) = Cells(RInp, "A").Resize(, 2).Value
　　　　　　ROut = ROut + 1
　　　　　　RSta = ROut
　　　　　　COut = 11
　　　　End If
'
　　　　Match = Cells(RInp, "D")
　　　　On Error Resume Next
　　　　Match = WorksheetFunction.Match(Match, [F1:H1], 0) + 5
　　　　On Error GoTo 0
'
　　　　If Cells(RInp, "D") = "" Then
　　　　ElseIf Val(Match) > 0 Then
　　　　　　Cells(ROut, Match) = NowKey
　　　　Else
　　　　　　Cells(ROut, COut).Resize(, 2) = Cells(RInp, "C").Resize(, 2).Value
　　　　　　COut = COut + 2
'
　　　　　　If COut = 17 Then
　　　　　　　　[F1:R1].Offset(ROut).Interior.Color = Color
　　　　　　　　ROut = ROut + 1
'
　　　　　　　　For COut = 6 To 9
　　　　　　　　　　Cells(RSta, COut).Resize(ROut - RSta + 1).Merge
　　　　　　　　Next COut
'
　　　　　　　　For COut = 17 To 18
　　　　　　　　　　Cells(RSta, COut).Resize(ROut - RSta + 1).Merge
　　　　　　　　Next COut
　　　　　　　　COut = 11
　　　　　　End If
　　　　End If
　　　　OldKey = NowKey
　　Next RInp
End Sub

お礼

ありがとうございます。
サンプルのものではできました。

実際に使いたいのが、もう少し複雑な文字列で（それが原因なのかもわからないのですが）
アレンジしたらできなくなってしまい、困っています。
また教えていただけませんでしょうか。
よろしくお願いいたします。