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

質問

以前に似たようなVBAの質問を元にさらにやりたいVBAがあるのですが、
（前の質問者のURL:http://okwave.jp/qa/q4955096.html)

　　　　　　Ａ列　　B列　　 C列　　 D列　　 E列 ～ R列
1行目　 佐藤 北海道　りんご　S　100　105

2行目　 佐藤 北海道　ばなな　M　100　105

3行目 伊藤　 東京　　いちご　S　100　105

4行目　 伊藤　 東京　　ばなな　M　100　105

上記のようなデーターがあります。これを2行目と4行目を削除し下記のようにしたいのですが

　　　　　　Ａ列　　B列　　 　　 C列　　 　　 C列
1行目　 佐藤 北海道　　りんご,ばなな　　S,M

2行目　 伊藤　 東京　　　いちご,ばなな　　S,M

A列とB列とE列～R列のデーターが同じでC列,D列,のデータが異なる場合、上記のように一行にまとめたいのです。関数やVBAで上記の処理を出来る方法がありますでしょうか。

回答No.3

tsubuyuki · ベストアンサー

並べ替えが出来てなくても何とか対応できるはずですが・・

Sub sample()
Dim OWS As Worksheet, NWS As Worksheet
Dim myKey As String, myRow As Long, TRow As Long
Dim i As Long, j As Long

Application.DisplayAlerts = False

For Each NWS In Worksheets
　　　　If NWS.Name = "結果" Then NWS.Delete
Next

Set OWS = Sheets("Sheet1")
Set NWS = Worksheets.Add
　　　　NWS.Name = "結果"

For i = 1 To OWS.Cells(Rows.Count, 1).End(xlUp).Row
　　　　myKey = OWS.Cells(i, 1) & OWS.Cells(i, 2)

　　　　For j = 5 To OWS.Cells(i, Columns.Count).End(xlToLeft).Column
　　　　　　　　myKey = myKey & OWS.Cells(i, j)
　　　　Next j

　　　　myRow = WorksheetFunction.CountA(NWS.Columns("A:A")) + 1

　　　　If NWS.Columns("E:E").Find(What:=myKey, LookAt:=xlWhole) Is Nothing Then
　　　　　　　　NWS.Cells(myRow, 1) = OWS.Cells(i, 1)
　　　　　　　　NWS.Cells(myRow, 2) = OWS.Cells(i, 2)
　　　　　　　　NWS.Cells(myRow, 3) = OWS.Cells(i, 3)
　　　　　　　　NWS.Cells(myRow, 4) = OWS.Cells(i, 4)
　　　　　　　　NWS.Cells(myRow, 5) = myKey
　　　　Else
　　　　　　　　TRow = NWS.Columns("E:E").Find(What:=myKey, LookAt:=xlWhole).Row
　　　　　　　　NWS.Cells(TRow, 3) = NWS.Cells(TRow, 3) & "," & OWS.Cells(i, 3)
　　　　　　　　NWS.Cells(TRow, 4) = NWS.Cells(TRow, 4) & "," & OWS.Cells(i, 4)
　　　　End If
Next i

NWS.Columns("E:E").Delete

Application.DisplayAlerts = True
End Sub

やってることはかなり強引ですが、多分できると思います。

補足

一通りできました。
3,4列で同じ言葉があったら、削除することって可能でしょうか？

りんご
りんご
ばなな
ばなな

だと、　りんご,りんご,ばなな,ばなな　となるんです。
これを、 りんご,ばなな

にしたいのです。

回答No.4

tsubuyuki

> 3,4列で同じ言葉があったら、削除することって可能でしょうか？

できますよ。

＃２さんのコードでも、＃３（私）のコードでも、
「内容を読み取って応用できれば」どうとでも出来ます。

がんばってくださいね。

補足

熟読して分析してみます。
またわからない意味があれば、その時はご教授いただければ幸いです。

回答No.2

tom04

こんにちは！
一例です。

A・B列は並び替えができているという前提です。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long
i = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
Range("A:A").Insert
Range("A1").Resize(i).Formula = "=CONCATENATE(B1,C1,F1,G1,H1,I1,J1,K1,L1,M1,N1,O1,P1,Q1,R1,S1)"
For i = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
With Cells(i, "A")
If .Value = .Offset(-1) Then
Cells(i - 1, "D") = Cells(i - 1, "D") & "," & Cells(i, "D")
Cells(i - 1, "E") = Cells(i - 1, "E") & "," & Cells(i, "E")
Rows(i).Delete
End If
End With
Next i
Range("A:A").Delete
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m（_ _）m

回答No.1

KURUMITO

元の表がシート1に有るとして1行目は項目名でお示しのデータが2行目から下方にあるとします。
作業列を作って対応します。
T2セルには次の式を入力します。式を確定する段階でCtrlキーとShiftキーを押しながらEnterキーを押します。

=IF(A2="","",IF(AND(A2:B2=A3:B3,E2:R2=E3:R3),ROUNDDOWN(MAX(T$1:T1),0)+1,IF(AND(A2:B2=A1:B1,E2:R2=E1:R1),T1+0.1,"")))

その式を下方にドラッグコピーします。
シート2はお求めの表でA2セルには次の式を入力して右横方向にドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX(Sheet1!$T:$T),"",IF(COLUMN(A1)<3,INDEX(Sheet1!$A:$B,MATCH(ROW(A1),Sheet1!$T:$T,0),COLUMN(A1)),IF(COLUMN(A1)=3,INDEX(Sheet1!$C:$C,MATCH(ROW(A1),Sheet1!$T:$T,0))&","&INDEX(Sheet1!$C:$C,MATCH(ROW(A1)+0.1,Sheet1!$T:$T,0)),IF(COLUMN(A1)=4,INDEX(Sheet1!$D:$D,MATCH(ROW(A1),Sheet1!$T:$T,0))&","&INDEX(Sheet1!$D:$D,MATCH(ROW(A1)+0.1,Sheet1!$T:$T,0)),""))))