excelで複数行にまたがるデータを1行にまとめたい

Ｅ列で折り返している同一種類のデータを1行のデータに変換したいです。
関数かＶＢＡで簡単にできないでしょうか？
よろしくおねがいします。

変更前
Ａ列 Ｂ列 Ｃ列 Ｄ列 Ｅ列 Ｆ列 Ｇ列 Ｈ列 Ｉ列 Ｊ列 Ｋ列
山田 A01 A02 A03 A04
山田 A05 A06 A07 A08
山田 A09 A10
田中 B01 B02 B03 B04
田中 B05 B06 B07
伊藤 C01 C02 C03

↓　
変更後
Ａ列 Ｂ列 Ｃ列 Ｄ列 Ｅ列 Ｆ列 Ｇ列 Ｈ列 Ｉ列 Ｊ列 Ｋ列
山田 A01 A02 A03 A04 A05 A06 A07 A08 A09 A10
田中 B01 B02 B03 B04 B05 B06 B07 B08
伊藤 C01 C02 C03

No.4 ベストアンサー 回答者： WindFaller 回答日時： 2018/05/20 12:12

#1さんの方法は、連想配列方式は、すぐに思いつきましたが、別の方法を考えました。

本来、構造が簡単なら、全て配列の中で行うのですが、ややこしくなるので、その都度、1次元の配列変数にする方式にしました。

'********開始行と開始列の部分を設定してください。E列だったら、5になります。
'出力側も自動で選べます。ワークシートは、データがぶつからない限りは、同じシート内でも出力可能です。

'//
Sub ConbineSameName()
Dim LastRow As Long
Dim i As Long, j As Long
Dim Flg As Boolean
Dim r As Variant, a As Variant, ar As Variant
Dim x As Long, y As Long, k As Long
Dim TotalA As Variant
Dim sh2 As Worksheet
Set sh2 = Worksheets("Sheet2") '同じシートでも書き出し可能
Dim stR As Long, stC As Long

'************************
'開始行と開始列
stR = 1: stC = 5
'シート2の書き出し行, 列
j = 1: k = 1
'******************
If sh2.Cells(j, k).CurrentRegion.Cells.Count > 2 Then
　If MsgBox(sh2.Name & "の目的の場所はすでに使われています。OKで実行", vbOKCancel) = vbCancel _
　Then Exit Sub
　sh2.Cells(j, k).CurrentRegion.ClearContents
End If

LastRow = Cells(Rows.Count, stC).End(xlUp).Row
For i = stR To LastRow
　If Cells(i, stC).Value <> "" Then
　 If Cells(i, stC).Value = Cells(i + 1, stC).Value Then
　　Flg = True
　 Else
　　Flg = False
　 End If
　 If TotalA = "" Then
　　r = Range(Cells(i, stC), Cells(i, Columns.Count).End(xlToLeft)).Value
　　TotalA = Join(Application.Index(r, 0), ",")
　 Else
　　r = Range(Cells(i, stC + 1), Cells(i, Columns.Count).End(xlToLeft)).Value
　　TotalA = TotalA & "," & Join(Application.Index(r, 0), ",")
　 End If
　 If Flg = False Then
　　ar = Split(TotalA, ",")
　　sh2.Cells(j, k).Resize(, UBound(ar) + 1).Value = ar
　　Erase r: TotalA = "": Erase ar
　　j = j + 1
　 End If
　End If
Next
sh2.Select
End Sub

この回答へのお礼

うまくいきました。
完璧ですありがとうございます。

お礼日時：2018/05/20 12:40

No.3 回答者： ママチャリ 回答日時： 2018/05/20 09:36

こんなのはどうでしょう。

関数で添付画像のようなシートを作ります。
【F2セル】=IF(A2<>A3,A2,"")
【G2セル】=IF(A2=A1,G1&CONCATENATE(","&B2&","&C2&","&D2&","&E2),CONCATENATE(B2&","&C2&","&D2&","&E2))

F:G列を別シートに値で張り付けて、F列（名前の列）が空白の行を削除し、「区切り位置」ウィザードでセルを分割します。
空白の削除は、ソートすると簡単です。元データにカンマが含まれている場合は、未使用の別の文字を使ってください。

No.2 回答者： mike_g 回答日時： 2018/05/20 07:51

添付図参照

Sheet1 において、
１．次の各セルにそれぞれ右側の式を入力
￣￣ G1: =COUNTIF($A$1:$A1,A1)
￣￣ H1: =IF(G1=1,COUNTIF($A$1:$A$6,A1),"")
￣￣ I1: =IF(H1="","",COUNTA(OFFSET(B1,,,H1,COLUMNS(B1:E1))))
￣￣ J1: =IF(OR($H1="",COLUMN(A1)>$I1),"",OFFSET($B$1,ROW(A1)-1+(COLUMN(A1)-1)/4,MOD(COLUMN(A1)-1,4)))
￣￣【お断り】上の I1、J1の式は必ず配列数式として入力のこと
２．セル J1 を右方に(此処では R列まで)ズズーッとオートフィル
３．範囲 G1:R1 を下方に(此処では 6行目まで)ズズーッとオートフィル

Sheet2 において、
４．次の配列数式を入力したセル Z1 を下方に(此処では 3行目まで)オート
￣￣フィル
￣￣ =INDEX(Sheet1!I$1:I$6,SMALL(IF(Sheet1!$G$1:$G$6=1,ROW(Sheet1!$G$1:$G$6),""),ROW(A1)))
５．次の各セルにそれぞれ右側の配列数式を入力
￣￣ A1: =INDEX(Sheet1!$A$1:$A$6,SMALL(IF(Sheet1!$G$1:$G$6=1,ROW(Sheet1!$G$1:$G$6),""),ROW(A1)))
￣￣ B1: =IF(COLUMN(A1)>$Z1,"",INDEX(Sheet1!J$1:J$6,SMALL(IF(Sheet1!$G$1:$G$6=1,ROW($F$1:$F$6),""),ROW(B1))))
６．セル B1 を右方に(此処では J列まで)ズズーッとオートフィル
７．範囲 A1:J1 を下方にオートフィル

No.1 回答者： tom04 回答日時： 2018/05/19 23:31

こんばんは！

VBAでの一例です。
元データはSheet1にあり、Sheet2に表示するとします。
尚、Sheet1は1行目からデータがあるという前提です。
標準モジュールにしてください。

Sub Sample1()
Dim myDic As Object
Dim i As Long, j As Long
Dim lastRow As Long, lastCol As Long
Dim myStr As String, wS As Worksheet
Dim myKey, myItem, myR, myAry

Set myDic = CreateObject("Scripting.Dictionary")
Set wS = Worksheets("Sheet2")
wS.Cells.ClearContents
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
lastCol = .UsedRange.Columns.Count
myR = Range(.Cells(1, "A"), .Cells(lastRow, lastCol))
For i = 1 To UBound(myR, 1)
For j = 2 To lastCol
If myR(i, j) <> "" Then
myStr = myStr & myR(i, j) & "_"
End If
Next j
If Not myDic.exists(myR(i, 1)) Then
myDic.Add myR(i, 1), Left(myStr, Len(myStr) - 1)
Else
myDic(myR(i, 1)) = myDic(myR(i, 1)) & "_" & Left(myStr, Len(myStr) - 1)
End If
myStr = ""
Next i
End With
myKey = myDic.keys
myItem = myDic.items
For i = 0 To UBound(myKey)
myAry = Split(myItem(i), "_")
wS.Cells(i + 1, "A") = myKey(i)
For j = 0 To UBound(myAry)
wS.Cells(i + 1, j + 2) = myAry(j)
Next j
Next i
Set myDic = Nothing
MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

ありがとうございました。
質問の希望通り動きました。
今回開始列をＡ列として質問しましたがＡ列～Ｄ列は他のデータが入っており開始列がＥ列からの場合だと、どうなるのでしょうか？
お手数ですがよろしくおねがいします。

お礼日時：2018/05/20 10:09