上下の値が一致したら、他の列の上下を統合し1行に

下記のようなデータがあります。

「名前」「内容」「日時」
田中　　報告1　　日時
田中　　報告2　　日時
田中　　報告3　　日時
吉田　　報告1　　日時
吉田　　報告2　　日時
佐々木　報告1　　日時
藤森　　報告1　　日時
藤森　　報告2　　日時
豊富　　報告1　　日時
豊富　　報告2　　日時

16000件あり、同一名で重複行を消すと5000件になります。



このデータを下記の通り、同じ人物の報告は1行のデータに変換したいです。

↓名前が同一だったら内容と日時を全て繋げて1つのフィールドに入れる

「名前」「内容」
田中　　[日時:報告1、日時:報告2、日時:報告3]
吉田　　[日時:報告1、日時:報告2]
佐々木　[日時:報告1]
藤森　　[日時:報告1、日時:報告2]
豊富　　[日時:報告1、日時:報告2]



関数を駆使して出来るのでしょうか。

マクロでしょうか。

お知恵をお貸しください。

尚、解りやすいように報告1、報告2と数字を付けていますが、
実際のデータには数字は付いていません。


何卒、宜しくお願い致します。

No.5 ベストアンサー 回答者： cj_mover 回答日時： 2014/09/17 11:35

こんにちは。

オーダーに忠実に書きました。
> 名前が同一だったら内容と日時を全て繋げて1つのフィールドに入れる
これはＶＢＡでやるしかないですね。

「どこ？」のデータを「どこ？」に出すか、
条件を開示されていない部分は、
そちらで運用に合わせて書き換えてください。

こちらで仮想の設定として、
アクティブなシートの　セルＡ１を含む一連の領域
　を
新しいシートの　セルＡ１を先頭とした領域
　に出力
するように書いてあります。

何かうまく出来ないことでもあれば、
補足欄にでも書いてみて下さい。

Sub Re8757443()
Dim arrK(), arrI()
Dim oDict As Object
Dim c As Range
Dim i As Long
　　Set oDict = CreateObject("Scripting.Dictionary")
　　For Each c In Range("A1").CurrentRegion.Resize(, 1)　 '　← 元データはどこら辺　？　"A1"　？
　　　　If oDict.Exists(c.Value) Then
　　　　　　oDict(c.Value) = oDict(c.Value) & "、" & c(1, 3).Value & " " & c(1, 2).Value
　　　　Else
　　　　　　oDict(c.Value) = c(1, 3).Value & " " & c(1, 2).Value
　　　　End If
　　Next
　　arrK() = oDict.Keys
　　arrI() = oDict.Items
　　Worksheets.Add After:=ActiveSheet　'　← 出力先は　？　新規のシート　？
　　For i = 1 To oDict.Count
　　　　Cells(i, "A") = arrK(i - 1)　'　← 出力先は　？　"A"列に　？
　　　　Cells(i, "B") = arrI(i - 1)　'　← 出力先は　？　"B"列に　？
　　Next i
　　Set oDict = Nothing
　　Range("A1").CurrentRegion.Columns.AutoFit　'　← 出力先はどこら辺　？　"A1"　？
End Sub

この回答へのお礼

とっても参考になるスクリプトありがとうございます！

インデントされていて見やすく、こちらで変更が必要な部分も明確になっていて、
尚且つ、実行結果の画像が「1つのフィールドに繋げて入れる」という希望通りの動作である事が一目で解かる回答であった為、とても良い回答だと思いました！

実際は繋げる内容は最大で53列＆40行にも及ぶのですが、
頂いたサンプルをカスタマイズして、無事に希望通りのスクリプトを作る事ができました！

お礼日時：2014/09/20 00:43

No.8 回答者： mitarashi 回答日時： 2014/09/18 00:42

#7です。

すみません、
Do Until rs.EOF
mySQL = "select 日時,内容 from [" & srcSheet.Name & "$] where 名前='" & rs.Fields(0).Value & "';"
＜以下略＞
に変更をお願いします。
ご質問では集計時日時が先でした。

No.7 回答者： mitarashi 回答日時： 2014/09/18 00:33

きっと受けないと思いますが、最近覚えた技で参戦してみます。

Sheet1のデータをSheet2に書き出します。xl2007以降対応のコードです。xl2003以前では小手直しの必要があります。
Sub test()
Dim cn As Object, rs As Object, rs2 As Object
Dim mySQL As String, buf As String
Dim srcSheet As Worksheet, destSheet As Worksheet
Dim mycell As Range

Const adClipString As Long = 2

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Set rs2 = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.ace.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0; HDR=Yes'"
.Open
End With
Set srcSheet = ThisWorkbook.Sheets("Sheet1")
Set destSheet = ThisWorkbook.Sheets("Sheet2")
destSheet.Range("A1:B1").Value = Array("名前", "内容")
Set mycell = destSheet.Range("A2")
mySQL = "select distinct 名前 from [" & srcSheet.Name & "$];"
rs.Open mySQL, cn
Do Until rs.EOF
mySQL = "select 内容,日時 from [" & srcSheet.Name & "$] where 名前='" & rs.Fields(0).Value & "';"
rs2.Open mySQL, cn
buf = rs2.GetString(adClipString, 5, ":", ",")
buf = Left(buf, Len(buf) - 1)
mycell.Value = rs.Fields(0).Value
mycell.Offset(0, 1).Value = buf
Set mycell = mycell.Offset(1, 0)
rs2.Close
rs.movenext
Loop
Set rs2 = Nothing
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

この回答へのお礼

スクリプトを考えて頂きありがとうございました。

実行結果のサンプル画像が希望通りを示したものになっていましたが

生憎、2003であった為、別の回答のスクリプトを優先に試しました。

すみません。

でも、参考になりました！

お礼日時：2014/09/20 00:53

No.6 回答者： cj_mover 回答日時： 2014/09/17 12:08

＃５、ｃｊです。

＃５に修正、自己レスです。

c(1, 3).Value
２か所ある記述を、どちらも
c(1, 3).Text
に書き換えてみて下さい

これで、元の表に「表示された日付」をトレースできます。
＃５のままでは、元の表の「表示値」をトレースしてしまうので、
臨んだ結果にならない場合があるかも知れませんので。

以上。修正案でした。

No.4 回答者： bunjii 回答日時： 2014/09/17 10:12

>名前が同一だったら内容と日時を全て繋げて1つのフィールドに入れる

関数では内容と日時を1組ずつ1つのフィールドへ抽出することになるでしょう。

貼付画像は提示された模擬データのみを使ってExcel 2013で検証したものです。
日時は判別できるように末尾に数字を加えました。
「名前」を単一化する数式をE2へセットしました。
「内容」は「内容1」、「内容2」、「内容3」のようにF列からI列へフィールドを作成しました。
E2=IFERROR(INDEX(A$1:A$1000,SMALL(IFERROR(MATCH(A$1:A$1000,A$1:A$1000,0),""),SUM(COUNTIF(A$1:A$1000,E$1:E1),1))),"")
この数式は配列数式になりますのでCtrlとShiftを押しながらEnterキーで確定してください。
F2=IFERROR(INDEX($C:$C,SUMPRODUCT(LARGE(($A$2:$A$11=$E2)*ROW(F$2:F$11),COUNTIF($A$2:$A$11,$E2)-COLUMN(A1)+1)),1),"")&":"&IFERROR(INDEX($B:$B,SUMPRODUCT(LARGE(($A$2:$A$11=$E2)*ROW(F$2:F$11),COUNTIF($A$2:$A$11,$E2)-COLUMN(A1)+1)),1),"")
こちらは通常通りEnterキーのみで確定して問題ありません。
日時については実際のデータに合わせてシリアル値をTEXT関数で文字列に置換してから連結する必要があるでしょう。
F2セルをオートフィルで右へI2セルへコピーしました。
E2からI2セルを選択して下へ必要数コピーすれば良いでしょう。

実際の処理ではデータ数が多いので自動再計算にすると待ち時間が長くなるでしょう。
ストレス解消には手動再計算にして必要時のみF9キーで再計算させることをお勧めします。

No.3 回答者： tom04 回答日時： 2014/09/17 08:48

こんにちは！

VBAでの一例です。

元データはSheet1に↓の画像のような配置であるとして、Sheet2に表示するとします。
尚、Sheet3を作業用のSheetとして使用しますので、Sheet3は使っていない状態にしておいてください。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, lastRow As Long, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS2.Range("A1"), unique:=True
For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS2.Cells(i, "A")
Range(.Cells(2, "B"), .Cells(lastRow, "C")).SpecialCells(xlCellTypeVisible).Copy
wS3.Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
For j = 1 To wS3.Cells(1, Columns.Count).End(xlToLeft).Column
wS2.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1) = wS3.Cells(2, j) & " " & wS3.Cells(1, j)
Next j
wS3.Cells.Clear
Next i
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
wS2.Columns.AutoFit
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
wS2.Activate
MsgBox "処理完了"
End Sub 'この行まで

※　関数でないのでSheet1に変更があるたびに
マクロを実行する必要があります。m(_ _)m

No.2 回答者： inakanoit 回答日時： 2014/09/17 05:32

16000件で報告１、報告２、報告３を試した結果です。