Excel 重複データ 横に並べたい

質問

下記となる様なに関数またはVBAを教えてください。
※下記スペースごとにセルが分かれてます。

SheetA
A りんご 100 30
A りんご 100 40
A りんご100 50
B もも 100 20
B もも 100 30

↓

※下記スペースごとにセルを分けたいです。

sheetB
Aりんご 100 30 りんご 100 40 りんご 100 50
B もも　100 20 もも 100 30

回答No.4

imogasi

データ例　Sheet1　配置が回答画面では乱れると思うが、手抜きですみません。
A りんご 100 30
りんご 100 40
りんご 100 50
りんご 100 60
B もも 100 20
もも 100 30
もも 100 70
ーーー
標準モジュールに
Sub test01()
cmax = Range("XfD1").Column
'データは100000行程度以内とする。
'--シートは元データはSheet1、結果はSheet3に作るとする
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet3")
sh2.Cells.Clear 'Sheet3の出るデータをクリア
k = 1
lr = sh1.Range("B100000").End(xlUp).Row 'Sheet1のB列最下行を取得
'MsgBox lr
For i = 1 To lr
If sh1.Cells(i, "B") <> "" Then
x = sh1.Cells(i, "B") 'りんごのような商品名?を取得
k = k + 1
'---Sheet3に第1のデータをセット
sh2.Cells(k, "A") = sh1.Cells(i, "A")
sh2.Cells(k, "B") = sh1.Cells(i, "B")
sh2.Cells(k, "C") = sh1.Cells(i, "C")
sh2.Cells(k, "D") = sh1.Cells(i, "D")
'---
'MsgBox x
' GoTo p1
'--りんごなど探索
'---検索範囲を定義
Set Rng = sh1.Range(sh1.Cells(2, "F"), sh1.Cells(100000, cmax))
'---探索
Set fnd = Rng.Find(x)
'MsgBox fnd
If fnd Is Nothing Then GoTo p1
r = fnd.Row '見つかった行
' MsgBox r
c1 = fnd.Column '見つかった列
'GoTo p2
'ーーー最初に見つかった分をSheet3にセット
C2 = sh2.Cells(k, 1000).End(xlToLeft).Column
sh2.Cells(k, C2 + 1) = sh1.Cells(r, c1)
sh2.Cells(k, C2 + 2) = sh1.Cells(r, c1 + 1)
sh2.Cells(k, C2 + 3) = sh1.Cells(r, c1 + 2)
fstrow = r
'=======第2以降のりんごなど探索＝＝＝＝＝
Do While Not fnd Is Nothing

' FindNextで検索を継続
Set fnd = Rng.FindNext(fnd)

' すべて検索し終えると最初に戻るので、Addressで確認！
' これを忘れると無限ループになるので注意！
If fnd.Row = fstrow Then '最初発見セルに戻った
Exit Do
Else
r = fnd.Row
c1 = fnd.Column
'--Sheet3に見つかったデータをセット。左寄せ的に３行分セット
C2 = sh2.Cells(k, cmax).End(xlToLeft).Column
sh2.Cells(k, C2 + 1) = sh1.Cells(r, c1)
sh2.Cells(k, C2 + 2) = sh1.Cells(r, c1 + 1)
sh2.Cells(k, C2 + 3) = sh1.Cells(r, c1 + 2)
End If
Loop
'ーーー
p2:
End If
p1:
Next i
End Sub
ーーー
実行結果　Ｓｈｅｅｔ３に
A りんご 100 30 りんご 100 40 りんご 100 50 りんご 100 60
B もも 100 20 もも 100 30 もも 100 70
＝＝＝
Ｆｉｎｄ法ともいえるもので、人間がコンピュターを使わず、紙と鉛筆で作業する（１９８０年代以前を想像？）ときのステップをなぞって、ＶＢＡコード化した方法。
だからロジックは奇抜なアイデアはなく、素直なんだが、Ｆｉｎｄ、ＦｉｎｄＮｅｘｔの使い方が、慣れないとむつかしい。他には、.ＥＮＤ（ＸＸＸＸ）を使っているぐらいで平凡で、面白味無し。
関数の回答が出ているので、その方法を勉強するほうが良いかな。
質問のデータ例のバラエティについて、十分ではないと思うので（数を増やすとともに、文章での注釈が必要と思う（ここの質問者では、それができない者が多い））、当方の勘違いがあるかもしれない。
また多数データでのテストが必要だか、時間的にもそれができない。
プロに頼む場合でも、いろいろな点を質問して確かめられるはずだ。そのそれをしないと、思わぬ予想外の結果になって、社内や世間を騒がせるものだ。
それが表現できないということは、コンピュータを仕事などには使うには、まだ早いということだろう。

お礼

ありがとうございます。

回答No.3

msMike

敢えて、關數版です。(^_^)

お礼

ありがとうございます。

回答No.2

msMike

敢えて、マクロに頼ら無い別觧です。マクロ化は御自分でだうぞ。(^_^)
添附圖參照(Excel 2019)
範圍 A1:J5 内でマウスをツン⇒Ctrl+Shift+:⇒Ctrl+G⇒[セル選択]⇒
“空白セル”に目玉入れ⇒[OK]⇒Ctrl+-⇒“上方向にシフト”に目玉入
れ⇒[OK]
範圍 A1:J5 内でマウスをツン⇒Ctrl+Shift+:⇒Ctrl+G⇒[セル選択]⇒
“空白セル”に目玉入れ⇒[OK]⇒Ctrl+-⇒“左方向にシフト”に目玉入
れ⇒[OK]
A列全體を選擇⇒Alt+AM⇒“現在選択…並べ替える”に目玉入れ⇒
[重複の削除]⇒[OK]⇒[OK]

回答No.1

SI299792

空白があって醜いですが、このようなデータ変換ですか。
Option Explicit
'
Sub Macro1()
　　Dim I As Worksheet
　　Dim RInp As Long
　　Dim ROut As Long
　　Dim Colu As Integer
　　Dim NowKey As String
　　Dim Oldkey As String
'
　　Set I = Sheets("SheetA")
　　Sheets("SheetB").Select
　　Application.ScreenUpdating = False
'
　　For RInp = 1 To I.Cells(Rows.Count, "A").End(xlUp).Row
　　　　NowKey = I.Cells(RInp, "A")
'
　　　　If NowKey <> Oldkey Then
　　　　　　Colu = 0
　　　　　　ROut = ROut + 1
　　　　　　Cells(ROut, "A") = NowKey
　　　　End If
　　　　[B1.D1].Offset(ROut - 1, Colu) = I.[B1:D1].Offset(RInp - 1).Value
　　　　Colu = Colu + 3
　　　　Oldkey = NowKey
　　Next RInp
End Sub

お礼

ありがとうございます。