エクセル複数行にまたがっているデータを一つの行 4

質問

エクセル　複数行にまたがっているデータを一つの行にまとめ（応用）

前回の質問（http://okwave.jp/qa/q8512057.html）で、なんとか成分の箇所を一列にまとめるところまではできたのですが、
行をまとめるに当たって「ナマエ」に対して一行にまとめたいのです。
説明しにくいので、申し訳ないのですが、以下のテンプレートのブックの「理想の結果」のようなかんじです。
https://box.yahoo.co.jp/guest/viewer?sid=box-l-q4e3edf5s4nuaeuieotgo6j6b4-1001&uniqid=fc6610c4-2d34-4f49-bc3d-0975f034bcdc&viewtype=detail

VBAでテンプレートブックの処理を出来る方法がありますでしょうか。

回答No.2

tom04

こんばんは！
前回投稿した者です。

結局Sheet2のA列名前で1行にまとめてしまいたい！というコトですよね？
ふつ～に考えると同姓同名の問題があると思いますので、
「ナマエ」と「産地」が重複している場合は同一人物と判断してやってみました。

Sheet1のサンプルを拝見すると同一名・同一品名の場合、I列以降のデータも同じみたいですので、
単純にA～H列までの判断でやっています。

最初からコードを考える気力がありませんので、前回のコードに追加してみました。
要は出来上がっているSheet2の最終行からE～H列にないものだけを追加しているだけです。

Sub Sample6()
Dim i As Long, j As Long, k As Long, n As Long, lastRow As Long, wS As Worksheet
Dim myStr1 As String, myStr2 As String, myStr3 As String, buf As String
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
wS.Rows(2 & ":" & lastRow).Clear
End If
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
.Cells(i, "A").Resize(, 8).Copy wS.Cells(i, "A")
.Cells(i, "AE").Resize(, 9).Copy wS.Cells(i, "J")
myStr1 = ""
myStr2 = ""
myStr3 = ""
buf = ""
For j = 9 To 17 Step 2
If .Cells(i, j) <> "" Then
myStr1 = myStr1 & " " & .Cells(i, j) & "," & .Cells(i, j + 1)
End If
Next j
For k = 19 To 23 Step 2
If .Cells(i, k) <> "" Then
myStr2 = myStr2 & " " & .Cells(i, k) & "," & .Cells(i, k + 1)
End If
Next k
For n = 25 To 29 Step 2
If .Cells(i, n) <> "" Then
myStr3 = myStr3 & " " & .Cells(i, n) & "," & .Cells(i, n + 1)
End If
Next n
If Len(myStr1) > 0 Then
buf = Left(.Cells(1, "I"), InStr(.Cells(1, "I"), "成分") - 1) & "成分" & "：" & Trim(myStr1)
End If
If Len(myStr2) > 0 Then
buf = buf & " " & Left(.Cells(1, "S"), InStr(.Cells(1, "S"), "成分") - 1) & "成分" & "：" & Trim(myStr2)
End If
If Len(myStr3) > 0 Then
buf = buf & " " & Left(.Cells(1, "Y"), InStr(.Cells(1, "Y"), "成分") - 1) & "成分" & "：" & Trim(myStr3)
End If
wS.Cells(i, "I") = buf
Next i
End With
'↓から追加
For i = wS.Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
If Cells(i, "A") = Cells(i - 1, "A") And Cells(i, "B") = Cells(i - 1, "B") And _
Cells(i, "C") = Cells(i - 1, "C") And Cells(i, "D") = Cells(i - 1, "D") Then '←A～D列が同じであれば・・・
If InStr(Cells(i, "E"), Cells(i - 1, "E")) = 0 Then
Cells(i - 1, "E") = Cells(i - 1, "E") & "," & Cells(i, "E")
Else
Cells(i - 1, "E") = Cells(i, "E")
End If
If InStr(Cells(i, "F"), Cells(i - 1, "F")) = 0 Then
Cells(i - 1, "F") = Cells(i - 1, "F") & "," & Cells(i, "F")
Else
Cells(i - 1, "F") = Cells(i, "F")
End If
If InStr(Cells(i, "G"), Cells(i - 1, "G")) = 0 Then
Cells(i - 1, "G") = Cells(i - 1, "G") & "," & Cells(i, "G")
Else
Cells(i - 1, "G") = Cells(i, "G")
End If
If InStr(Cells(i, "H"), Cells(i - 1, "H")) = 0 Then
Cells(i - 1, "H") = Cells(i - 1, "H") & "," & Cells(i, "H")
Else
Cells(i - 1, "H") = Cells(i, "H")
End If
Rows(i).Delete
End If
Next i
'↑ココまで追加
With wS
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Range(.Cells(1, "A"), .Cells(lastRow, "K")).Borders.LineStyle = xlContinuous
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

※　前提条件として、「ナマエ」と「産地」は同一人物の場合はきっちり並んでいるとします。
もしバラバラになっている場合は
Sheet1のA列を並び替えキーの1番目・B列を並び替えキーの2番目として並び替えを行った後に
マクロを実行してみてください。m（_ _）m

補足

「ナマエ」と「産地」が重複している場合は基本的にないので、その判断は必要なかったです。(ナマエはIDになっていますので。）

またSheet1まとめられているのですが、Sheet2がまとめられていないのです。。
自ら直そうととおもっていじってはみたいのですが、まったくお手上げ状態でした・・・。
どうかお力をいただけないでしょうか

回答No.1

karorumon

一応、プログラムのほうが考え中ですが…、少し自分でやってみたほうが良いかと思いますよ？
このプログラムの場合、作るのが面倒なだけで
簡単だと思いますし…

自分で作ってみないと、何かあったときに何処が悪かったか
判断できなくて困ることになると思います。