【Excel VBA】重複行の削除

質問

はじめまして。
IDの重複を削除し、日付データを横1列にまとめるVBAについてご教示いただけますと幸いです。

-------------------------------------------------------

▼シート1（データ入力がされているシート）

　　　A　　　B　　　C　　　D　　　E　　　F　　　
1　　　ID　日付
2　　1234　　1/1　　1/6　　1/10　　1/20　　
3　　1234　　2/3　　2/20
4　　1234　　3/2
5　　7777　　1/10　　1/15　　1/20
6　　7777　　2/2　　　2/12　　2/22
7　　9876　　2/3

⇓ マクロ起動後

▼シート2（重複行を削除しまとめたシート）
　　　A　　　B　　　C　　　D　　　E　　　F　　　G　　　H
1　　　ID　日付
2　　1234　　1/1　　1/6　　1/10　　1/20　　2/3　　2/20　　3/2
3　　7777　　1/10　 1/15　 1/20　　2/2　 2/12　　2/22
4　　9876　　2/3

【補足】
列情報
　・A列…ID
　・B-F列…日付（左詰め）

※日付はIDごと月毎に行が変わるため、IDによって複数行存在する場合があります。
※A列のIDは重複しない場合もあれば、4行以上ある場合があります。
※シート１のデータはおおよそ1000-5000行です。
※IDに対して、日付は５つあれば問題ありません。そのためG列以降の日付を削除しても支障はございません。

------------------------------------------------------
VBAの知識があまりなく、調べて出てきたものをコピペ使用も試みたのですが、
上手く動かす事ができませんでした…。
お力添え頂けますと幸いです…。
Windows10でエクセル2016を使用しております。

何卒宜しくお願いいたします。

回答No.2

kkkkkm · ベストアンサー

IDの型が不明なのでVariantにしてます。ID順に並んでいるという考えなので最初にID順に並び替えてます。

Sub Test()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Sh1LastRow As Long, Sh2LastRow As Long
Dim Sh1LastColumn As Long, Sh2LastColumn As Long
Dim c As Range, ID As Variant: ID = ""

Set Sh1 = Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")

Sh1LastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row

Sh1.Sort.SortFields.Clear
Sh1.Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues
With Sh1.Sort
.SetRange Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "G"))
.Header = xlNo
.Orientation = xlTopToBottom
.Apply
End With
For Each c In Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "A"))
Sh1LastColumn = Sh1.Cells(c.Row, Columns.Count).End(xlToLeft).Column
Sh2LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row
Sh2LastColumn = Sh2.Cells(Sh2LastRow, Columns.Count).End(xlToLeft).Column
If c.Value = ID Then
Sh2.Cells(Sh2LastRow, Sh2LastColumn + 1).Resize(1, Sh1LastColumn - 1) = _
Sh1.Range(Sh1.Cells(c.Row, "B"), Sh1.Cells(c.Row, Sh1LastColumn)).Value
Else
Sh2.Cells(Sh2LastRow + 1, "A").Resize(1, Sh1LastColumn) = _
Sh1.Range(Sh1.Cells(c.Row, "A"), Sh1.Cells(c.Row, Sh1LastColumn)).Value
ID = c.Value
End If
Next

Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

回答No.9

masnoske

[No.7] です。
セル番地を使わずにレンジだけで処理してみました。
こちらのほうがコードがスッキリしています。

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim rng As Range ' リストの作成元
Dim src As Range ' シート1 のコピー元
Dim dest As Range ' シート2 のコピー先
Dim endCell As Range ' シート2 のコピー終了セル
Dim rng1 As Range ' シート1 のA列ループ用
Dim rng2 As Range ' シート2 のA列ループ用

Set sh1 = Sheets("シート1")
Set sh2 = Sheets("シート2")

' シート2 の値ををクリアする
sh2.Cells.ClearContents

' リスト作成元の範囲を設定する
Set rng = Range(sh1.Range("A1"), sh1.Range("A1").End(xlDown))

' リストを作成する
rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sh2.Range("A1"), Unique:=True

' シート2 に一覧を作成する
For Each rng2 In Range(sh2.Range("A2"), sh2.Range("A2").End(xlDown))
' シート2 の A列をループ
Set endCell = rng2
For Each rng1 In Range(sh1.Range("A2"), sh1.Range("A2").End(xlDown))
' シート1 の A列を縦方向にループ
If rng1.Value = rng2.Value Then
' コピー
Set src = Range(rng1.Offset(0, 1), rng1.End(xlToRight))
Set dest = Range(endCell.Offset(0, 1), endCell.Offset(0, src.Count))
src.Copy dest
Set endCell = endCell.Offset(0, src.Count)
End If
Next
Next

お礼

返答いただき有難うございます！
お返事が遅くなってしまい申し訳ありません。

こんなにも短くまとまるものなのですね…
一度導入してみます。ありがとうございました！

回答No.8

kkkkkm

No2の一部に抜けがありました。動作に問題はないと思いますが念のために訂正部分を

Sh1.Sort.SortFields.Add Key:=Range("A2"), _
を
Sh1.Sort.SortFields.Add Key:=Sh1.Range("A2"), _

For Each c In Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "A"))
を
For Each c In Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "A"))

あと、訂正だけではあれですので余計なお世話を…
シート2にまとめた後に日付部分が順に並んでいない場合(もとのデータが並んでいなかった場合)
最後にソートするコードを付加します。(データが日付として入っていないと順になりません)

For Each c In Sh2.Range(Sh2.Cells(2, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp))
Sh2LastColumn = Sh2.Cells(c.Row, Columns.Count).End(xlToLeft).Column
With Sh2.Sort
With .SortFields
.Clear
.Add Key:=Sh2.Cells(c.Row, "B"), SortOn:=xlSortOnValues
End With
.SetRange Sh2.Range(Sh2.Cells(c.Row, "B"), Sh2.Cells(c.Row, Sh2LastColumn))
.Header = xlNo
.Orientation = xlLeftToRight
.Apply
End With
Next

また、各行の日付は横方向に順に並んでいるが以下のように行が上下している場合には
2　　1234　　2/3　　2/20
3　　1234　　1/1　　1/6　　1/10　　1/20　　
元の最初のソート部分
Sh1.Sort.SortFields.Clear
から
End With
までを以下のように変更すると上記の最後のソートは不要です。
With Sh1.Sort
With .SortFields
.Clear
.Add Key:=Sh1.Range("A2"), SortOn:=xlSortOnValues
.Add Key:=Sh1.Range("B2"), SortOn:=xlSortOnValues
End With
.SetRange Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "Z"))
.Header = xlNo
.Orientation = xlTopToBottom
.Apply
End With

回答No.7

masnoske

すでにソートされているのなら，処理は簡単です．
（1）シート1のA列から重複がないリストをシート2のA列に作る．
（2）シート2のA列と同じデータをシート1のA列から探し，見つかったら行の最後までをシート2にコピーする．
以上です．

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim rng As Range
Dim r1 As Long ' シート1 の行番号
Dim c1 As Long ' シート1 の列番号
Dim r2 As Long ' シート2 の行番号
Dim c2 As Long ' シート2 の列番号

Set sh1 = Sheets("シート1")
Set sh2 = Sheets("シート2")

' シート2 の値ををクリアする
sh2.Cells.ClearContents

' リスト作成元の範囲を設定する
Set rng = Range(sh1.Cells(1, 1), sh1.Cells(1, 1).End(xlDown))

' リストを作成する
rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sh2.Cells(1, 1), Unique:=True

' シート2 に一覧を作成する
r1 = 2
r2 = 2
Do While sh2.Cells(r2, 1).Value <> ""
' シート2 の A列をループ
c2 = 2
Do While sh1.Cells(r1, 1).Value = sh2.Cells(r2, 1).Value
' シート1 の A列を縦方向にループ
c1 = 2
Do While sh1.Cells(r1, c1).Value <> ""
' シート1 の B列から横方向にループ
sh2.Cells(r2, c2).Value = sh1.Cells(r1, c1).Value
c1 = c1 + 1
c2 = c2 + 1
Loop
r1 = r1 + 1
Loop
r2 = r2 + 1
Loop

回答No.6

imogasi

Sheet1に元データ
Sheet2に結果を入れるとして
ーー
前処理として、Sheet1のA列でソートしておく。シートはVBAでも簡単だが、今回は手操作。
キモは、Range( ).End( )の応用問題という感じ。
ーー
標準モジュールに
Sub test01()
Set sh1 = Worksheets("Sheet1") '原シート
Set sh2 = Worksheets("Sheet2") '集約シート
lr = sh1.Cells(10000, "A").End(xlUp).Row 'Sh1シートのデータ最下行
'MsgBox lr
'--
maekey = sh1.Cells(2, "A") 'Sh1シート第１レコードのキー　第１行目は見出し

k = 2 'Sh2シートのk行に集約中、その最初行を２に指定Rick
rc1 = sh1.Cells(2, 100).End(xlToLeft).Column
sh1.Cells(2, 1).Copy sh2.Cells(2, 1) '集約シートSh2の第２行へ
rc2 = sh2.Cells(2, 1000).End(xlToLeft).Column
Range(sh1.Cells(2, 2), sh1.Cells(2, rc1)).Copy sh2.Cells(k, rc2 + 1)
'--
For i = 3 To lr
If sh1.Cells(i, "A") = maekey Then
'変わらない場合
rc1 = sh1.Cells(i, 100).End(xlToLeft).Column
rc2 = sh2.Cells(k, 1000).End(xlToLeft).Column
Range(sh1.Cells(i, 2), sh1.Cells(i, rc1)).Copy sh2.Cells(k, rc2 + 1)
Else
'変わった
k = k + 1 '集約行を１つ下へポイント
sh2.Cells(k, 1) = sh1.Cells(i, "A")
rc1 = sh1.Cells(i, 100).End(xlToLeft).Column
Range(sh1.Cells(i, 2), sh1.Cells(i, rc1)).Copy sh2.Cells(k, 2)
End If
maekey = sh1.Cells(i, "A")
Next i
End Sub
ーーーー
テストデータ　Sheet1
ID 日付
1234 1月1日 1月6日 1月10日 1月20日
1234 2月3日 2月20日
1234 3月2日
7777 1月10日 1月15日 1月20日
7777 2月2日 2月12日 2月22日
9876 2月3日
ーー
結果Sheet2
ID 日付　＜－手入力
1234 1月1日 1月6日 1月10日 1月20日 2月3日 2月20日 3月2日
7777 1月10日 1月15日 1月20日 2月2日 2月12日 2月22日
9876 2月3日
＝＝＝
質問の標題の
＞重複行の削除 　は適当では無いと思う（内容を表してない）。
ーー
色々な処理ロジックが考えられるが
（１）本回答は、sort後に、前の行と比較法です
（２）同じキーをSheet2のA列でFind法なども考えられると思うが。
ーー
書式はあまり考えてない。
コードの中の、列番号の１００，１００は適当に修正のこと。

お礼

imogasiさん、ありがとうございます。

何がどのような動きを書いてくださりありがとうございます。
確認してみます！

〉質問の標題の ＞重複行の削除 　は適当では無いと思う（内容を表してない）。
→失礼しました。具体的に何も書かれていませんね…
　次回質問する際には細かく書くよう気を付けます。
　ご指摘ありがとうございます。

回答No.5

masnoske

> VBAの知識があまりなく、調べて出てきたものをコピペ使用も試みたのですが、

VBAの知識がないのは仕方ないですが，あなたは作ったマクロを今後どうしたいのでしょうか．
ただ答えが欲しいだけなのか，今後は自分でメンテするのか，今後もメンテをここに依頼するのか．

補足

今手作業で行っている入力作業や確認作業がとても多く、何とか簡略化できないかな？と
調べた結果、VBA（マクロ？）というものがあることを知りました。

ここで教えていただいた内容をちょっとずつ分解して、
使える範囲を広げられたらと思っています。

なので、現状は答えが欲しいです。
ただ今後メンテもしていきたいし、また躓いてしまったら質問させて頂く事もあるかと思います…。

ハッキリとした回答ができず申し訳ございません。

回答No.4

kkkkkm

No2です。なんどもすみません。

データが多い場合、画面の表示を止めたほうが早いと思いますので
最初に
Application.ScreenUpdating = False
最後に
Application.ScreenUpdating = True
を追加しておいてください。

なお、データを下方向に追加していますので同じデータで複数回実行すると実行した回数だけデータが下方向に蓄積されていきます。。

お礼

ありがとうございます！
Excelに入れ込み、動かしてみます…！

丁寧に説明いただき、ありがとうございました。

回答No.3

kkkkkm

No2です。
With Sh1.Sort
.SetRange Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "G"))
の
最後のGは最後のデータがある可能性のある列まで(たとえばZまで)とか指定してください。右端の列までをシート2に転記しますので並び替えの時に右端まで並び替えていないと結果がおかしくなります。テストでGまでしかデータがなかったのでとりあえずGまでとしたままになりました。

回答No.1

masnoske

質問があります。
提示されているデータは縦方向にA列、B列について昇順にソートされています。
次に横方向は左側から順に日付が並んでいます。
この状態からのスタートでしょうか。
あるいは、そもそもバラバラに並んでいるデータで、この順に並べる必要があるのでしょうか。

補足

masnoskeさん

質問ありがとうございます。

＞この状態からのスタートでしょうか。
→おっしゃる通りです。
　A列のIDは4～5桁で昇順です。
　B列以降は左詰めです。

バラバラに並べられたデータを、一つ前の処理で上記順番に並び替えています。

宜しくお願いいたします。