• ベストアンサー
  • すぐに回答を!

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

  • 質問No.4955096
  • 閲覧数864
  • ありがとう数2
  • 回答数4

お礼率 60% (35/58)

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

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

4行目  伊藤  東京  ばなな 

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

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

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

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

質問者が選んだベストアンサー

  • 回答No.3
  • ベストアンサー

ベストアンサー率 48% (1930/4007)

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
お礼コメント
masa1717

お礼率 60% (35/58)

多くのデーターの処理にたいしても、時間が殆どかからず出来ました。助かりました。有難うございます。
投稿日時:2009/05/14 17:12

その他の回答 (全3件)

  • 回答No.4

ベストアンサー率 38% (1910/4994)

VBAでないと難しいと思いますので一例です。(E・F・G列に展開します)
(1)対象のシートタブ上で右クリック→コード表示
(2)以下のコードを貼り付け
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
(3)VBEを終了(Alt+F4キー押下)
  • 回答No.2

ベストアンサー率 14% (137/953)

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

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

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

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

ベストアンサー率 61% (1594/2576)

とりあえず、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
関連するQ&A

その他の関連するQ&Aをキーワードで探す

ページ先頭へ