VBAで重複データのセルを移動したい

質問

下記のようなExcelの表があります。

コードA　コードB　本文　言語　図面種類　図面名
　1　　　　ａ　　　123　　J　　　tif　　a.tif
　2　　　　 b　　　456　　E　　　pdf　　b.pdf
　3　　　　c　　　789　　　J　　gif　　　c.gif
　4　　　　a　　　145　　　E　　eps　　　a_1.eps
　5　　　　d　　　235　　　E　　tif　　　d.tif
　6　　　　c　　　467　　　E　　pdf　　　c_1.pdf
　7　　　　a　　　345　　　J　　gif　　　a_2.gif

これを、コードBが重複する行があれば、行の中の言語、図面種類、図面名をコードAが一番早い数字の最終列に移動するVBAを作成したいと思っています。

コードA　コードB　本文　言語　図面種類　図面名　言語　図面種類　図面名 言語　図面種類　図面名
　1　　　　ａ　　　123　　J　　　tif　　　a.tif　　E　　eps　　a_1.eps　J　　gif　　　a_2.gif
　2　　　　 b　　　456　　E　　　pdf　　b.pdf
　3　　　　c　　　789　　　J　　gif　　　c.gif　　E　　pdf　　　c_1.pdf
　5　　　　d　　　235　　　E　　tif　　　d.tif
　7　　　　a　　　345　　　J　　gif　　　a_2.gif

検索して下記のページを見つけ、いろいろ調べて変更してみたのですが、Cellsの指定方法がよくわからず、先に進めません。
どのようにしたら上記の結果を表示できるか、お助け頂けないでしょうか？
http://okwave.jp/qa552017.html

Sub transform()

Dim x As Integer
Dim y As Integer

y = 3 '先頭のデータの行

Do Until Cells(y + 1, 2).Value = "" '重複セルの列の値が空になるまでループする

y = y + 1

If Cells(y, 2).Value = Cells(y - 1, 2).Value Then
x = Cells(y - 1, 2).End(xlToRight).Column + 1 '最終列の隣に追加
Cells(y - 1, x).Value = Cells(y, 2).Value
Cells(y, 2).EntireRow.Delete
y = y - 1

End If

Loop

End Sub

回答No.4

hotosys · ベストアンサー

7行目は削除されるでいいのかな?
Sub sample()
Dim r As Long
r = 2
Do While Cells(r, 2) <> ""
If WorksheetFunction.CountIf(Range("B2").Resize(r - 1, 1), Cells(r, 2)) > 1 Then
Cells(r, 4).Resize(1, 3).Copy Destination:=Cells(Range("B1").Resize(r, 1).Find(Cells(r, 2)).Row, Columns.Count).End(xlToLeft).Offset(0, 1)
Rows(r).Delete
Else
r = r + 1
End If
Loop
End Sub

お礼

回答ありがとうございます！
7行目は削除されるで問題ありません！
スクリプトを実行してみたら、見事できました。
この2日くらいずっと悩んでいたので、エラーなく動作をしているのを見て感動してしまいました。
またスクリプトの中のRangeオブジェクト、Copy Destinationなどを検索していたら、とても参考になるサイトも見つけられました。
とても助かりました。本当に、ありがとうございます！！

回答No.5

n-jun

Sub try()
Dim Dic As Object
Dim i As Long, j As Long
Dim k As Long, m As Integer, Max_col As Integer
Dim v, vv

Set Dic = CreateObject("Scripting.Dictionary")

With Worksheets("Sheet1")
v = .Range(.[A3], .Cells(Rows.Count, 1).End(xlUp).Resize(, 6)).Value
End With

ReDim vv(1 To UBound(v, 1), 1 To 256)
For k = 1 To UBound(v, 1)
If Not Dic.Exists(v(k, 2)) Then
i = i + 1
For m = 1 To 6
vv(i, m) = v(k, m)
Next
Dic(v(k, 2)) = Array(i, 6)
Else
For m = 1 To 3
vv(Dic(v(k, 2))(0), Dic(v(k, 2))(1) + m) = v(k, m + 3)
Next
Dic(v(k, 2)) = Array(Dic(v(k, 2))(0), Dic(v(k, 2))(1) + 3)
If Max_col < Dic(v(k, 2))(1) Then Max_col = Dic(v(k, 2))(1)
End If
Next

With Worksheets("Sheet2")
.Cells.ClearContents
.Range("A3").Resize(Dic.Count, UBound(vv, 2)).Value = vv
.Range("A2").Resize(, 6).Value = Worksheets("Sheet1").Range("A2").Resize(, 6).Value
.Range("D2").Resize(, 3).AutoFill Destination:=Range("D2").Resize(, Max_col - 3),
Type:=xlFillDefault
End With
Erase v, vv
Set Dic = Nothing
End Sub

お礼

回答ありがとうございます！
こちらは新しいワークシートにデータを移行する方法ですね。
こちらもとても参考になりました。
ありがとうございます！！

回答No.3

imogasi

問題は＞コードBが重複する行があれば
の重複をどういう風にVBAコードでに検出するかにある。
この点がポイントなのに、検討した形跡が見られない。確かにプログラムの多数の経験がなければ、１－２時間考えても、そう浮かんでこないでしょうが。
これも他人の回答を見習うより他無いのだろう。
ーーー
（１）ソート法
（２）カウント法
（３）Find法
など思い浮かぶ。
（１）はB列でソートすると例えばaの行は固まる。その状態を使う。
ロジックは一番簡単になるでしょう。
（３）はB列でaを見つけるFindメソッドを発行し、見つかれば所定の
処理をし、見つかった次の行以下を対象に、aを見つけるFindメソッドを発行し、最終まで繰り返す。ただ見つかった行をまた
検索しないような仕掛けが必要です。少し複雑。
＝＝
例データ　B1:C１０
a X
s Y
x V
c W
d Z
a T
d S
a R
f Q
c P
ーーー
コード
Sub test01()
d = Range("B65536").End(xlUp).Row
For i = 1 To d
x = Application.WorksheetFunction.CountIf(Range("B1:B" & i), Range("B" & i))
If x > 1 Then
' 重複行の下の行探知
y = Application.WorksheetFunction.Match(Range("B" & i), Range("B1:B100"), 0)
c = Range("az" & y).End(xlToLeft).Column '右端列の探知
Cells(y, c + 1) = Cells(i, "B").Offset(0, 1) '隣列データ
End If
Next i
'---重複行削除
For i = d To 1 Step -1
x = Application.WorksheetFunction.CountIf(Range("B1:B" & i), Range("B" & i))
If x > 1 Then
Cells(i, "B").EntireRow.Delete
End If
Next i
End Sub
上記はC列１列しか右へ累積していないので、質問のためには手直し必要。言語、図面種類、図面名の３列づつ（３列分）移す（累積する）ように手直しが必要。
ちょっと危ないロジックかなと思うので、ソート法を薦めます。
ーー
結果
B列　　C列　　　　D列　　　E列（C列以右列に累積）
a X T R
s Y
x V
c W P
d Z S
f Q

お礼

回答ありがとうございます！
ご指摘の通り、プログラムの経験がほとんどなく、VBAも今回が初めてと言っていいほどです。
Cellsの値を検討してみたのですが全くうまくいかず、結局元に戻して掲載しました…。
いろいろと考え方を提示くださってありがとうございます。
とても参考になりました。

回答No.2

keirika

提示されたＶＢＡを少し作り直してみました。

何かの参考になれば幸いです。

Sub transform()

Dim x As Integer
Dim y As Integer

y = 3 '先頭のデータの行

Do Until Cells(y + 1, 2).Value = "" '重複セルの列の値が空になるまでループする

If Cells(y, 2).Value = Cells(y + 1, 2).Value Then
x = Cells(y, 256).End(xlToLeft).Column + 1 '最終列の隣に追加
Cells(y, x) = Cells(y + 1, 2)
Cells(y + 1, 2).EntireRow.Delete
Else
y = y + 1
End If

Loop

End Sub

お礼

回答ありがとうございます！
試してみましたが、図面種類などは追加されず、右側に1つずつコードBが追加されたのみでした。
でも、考えて下さってありがとうございました！

回答No.1

n-jun

リンク先の回答の場合は、比較したいデータが並んでいる時には使えますが、
提示されている表の様子からだと、ちょっと違うように思います。

>コードBが重複する行があれば、行の中の言語、図面種類、図面名をコードAが一番早い数字の最終列に移動する
だとすると、
>7　　　　a　　　345　　　J　　gif　　　a_2.gif
は
>1　　　　ａ　　　123　　J　　　tif　　　a.tif　　E　　eps　　a_1.eps　J　　gif　　　a_2.gif
ここに来るはずですが・・・？
間違えか、条件が別にあるのか、不明です。

あと、コードＡは昇順に並んでいると言う事でしょうか？

お礼

回答ありがとうございます！
ご指摘の通り、7は消し忘れです。
混乱させてしまい申し訳ありません…。
コードAは昇順に並んでいます。