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

　　　　　　Ａ列　　B列　　 C列
1行目　 佐藤 北海道　りんご

2行目　 佐藤 北海道　ばなな
　
3行目 伊藤　 東京　　いちご

4行目　 伊藤　 東京　　ばなな　

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

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

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

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

No.3 ベストアンサー 回答者： merlionXX 回答日時： 2009/05/13 14:39

VBAの一例です。

新たなシートを追加してそこにご希望の状態を表示させます。
ご提示のデータはA1から連続してあるものとします。

Sub test01()
Dim x As Long, i As Long, myStr As String
Dim vAK, vBK, vCI
Dim myDic As Object, ns As Worksheet
With Range("A1").CurrentRegion.Columns 'A1の連続範囲
x = .Rows.Count '行数取得
vAK = .Item(1).Value '1列目データ
vBK = .Item(2).Value '2列目データ
vCI = .Item(3).Value '3列目データ
End With
Set myDic = CreateObject("Scripting.Dictionary")
For i = 1 To x '1行目から最終行まで
myStr = vAK(i, 1) & "＾" & vBK(i, 1) '1列目データ+2列目データ
If Not myDic.Exists(myStr) Then 'myDicになければ
myDic.Add Key:=myStr, Item:=vCI(i, 1) '追加
Else 'あれば、3列目データを追加
myDic(myStr) = myDic(myStr) + vCI(i, 1)
End If
Next i
Set ns = Worksheets.Add(After:=ActiveSheet) 'シートを追加
With ns '転記して分離
.Cells(1, 1).Resize(myDic.Count).Value = Application.Transpose(myDic.Keys) '
.Cells(1, 3).Resize(myDic.Count).Value = Application.Transpose(myDic.Items) '
.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Other:=True, OtherChar _
:="＾", FieldInfo:=Array(Array(1, 1), Array(2, 1))
End With
End Sub

この回答へのお礼

多くのデーターの処理にたいしても、時間が殆どかからず出来ました。助かりました。有難うございます。

お礼日時：2009/05/14 17:12

No.4 回答者： mu2011 回答日時： 2009/05/13 14:47

ＶＢＡでないと難しいと思いますので一例です。

（Ｅ・Ｆ・Ｇ列に展開します）
（１）対象のシートタブ上で右クリック→コード表示
（２）以下のコードを貼り付け
Sub データ統合()
Dim a, e As Range
For Each a In Range("A:A")
If a.Value = "" Then Exit Sub
For Each e In Range("E:E")
If e.Value = "" Then
Range("E1").Offset(e.Row - 1) = a
Range("F1").Offset(e.Row - 1) = Range("B1").Offset(a.Row - 1)
Range("G1").Offset(e.Row - 1) = Range("C1").Offset(a.Row - 1)
Exit For
Else
If e = a And Range("F1").Offset(e.Row - 1) = Range("B1").Offset(a.Row - 1) Then
x = InStr(1, Range("G1").Offset(e.Row - 1), Range("C1").Offset(a.Row - 1), vbTextCompare)
If x > 0 Then Exit For
Range("G1").Offset(e.Row - 1) = Range("G1").Offset(e.Row - 1) & Range("C1").Offset(a.Row - 1)
Exit For
End If
End If
Next
Next
End Sub
（３）VBEを終了（Alt＋F4キー押下）

No.2 回答者： ookami1969 回答日時： 2009/05/13 13:25

まず一旦、B列のグループごとに集計し直して そこから作業を始めてはいかがですか？

フィルタで「北海道」を抽出して「シート北海道」にまとめて移すとか。

あとは 「北海道でりんごが2件も3件もあったらどうするのか」等々
場合により処理の仕方が変わると思うのですが。。。

まぁ どちらにせよ一旦「作業用シート」で作業を行って元のシートに戻せば関数もVBAも必要ないですね。

No.1 回答者： fujillin 回答日時： 2009/05/13 13:14

とりあえず、VBAでの一例です。

Sub test()
Dim rmax As Long, rw As Long, r As Long
Dim v1 As String, v2 As String, st As String

rmax = Cells(Rows.Count, 1).End(xlUp).Row
For rw = 1 To rmax - 1
　st = Cells(rw, 3).Text
　v1 = Cells(rw, 1).Value
　If v1 <> "" And v1 <> Chr(27) Then
　　v2 = Cells(rw, 2).Value
　　For r = rw + 1 To rmax
　　　If Cells(r, 1).Value = v1 And Cells(r, 2).Value = v2 Then
　　　　st = st & Cells(r, 3).Text
　　　　Cells(r, 1).Value = Chr(27)
　　　End If
　　Next r
　　Cells(rw, 3).Value = st
　End If
Next rw
For r = rmax To 1 Step -1
　If Cells(r, 1).Value = Chr(27) Then Cells(r, 1).Resize(1, 3).Delete (xlShiftUp)
Next r
End Sub