こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

【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行以上ある場合があります。
※シート1のデータはおおよそ1000-5000行です。
※IDに対して、日付は5つあれば問題ありません。そのためG列以降の日付を削除しても支障はございません。

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

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

投稿日時 - 2020-03-26 15:56:03

QNo.9727763

困ってます

質問者が選んだベストアンサー

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

投稿日時 - 2020-03-26 17:56:43

ANo.2

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(9)

ANo.9

[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

投稿日時 - 2020-03-27 09:31:06

お礼

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

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

投稿日時 - 2020-04-01 15:06:13

ANo.8

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

投稿日時 - 2020-03-27 07:53:06

ANo.7

すでにソートされているのなら,処理は簡単です.
(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

投稿日時 - 2020-03-26 23:15:49

ANo.6

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シート第1レコードのキー 第1行目は見出し

k = 2 'Sh2シートのk行に集約中、その最初行を2に指定Rick
rc1 = sh1.Cells(2, 100).End(xlToLeft).Column
sh1.Cells(2, 1).Copy sh2.Cells(2, 1) '集約シートSh2の第2行へ
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 '集約行を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日付
12341月1日1月6日1月10日1月20日
12342月3日2月20日
12343月2日
77771月10日1月15日1月20日
77772月2日2月12日2月22日
98762月3日
ーー
結果Sheet2
ID日付 <-手入力
12341月1日1月6日1月10日1月20日2月3日2月20日3月2日
77771月10日1月15日1月20日2月2日2月12日2月22日
98762月3日
===
質問の標題の
>重複行の削除  は適当では無いと思う(内容を表してない)。
ーー
色々な処理ロジックが考えられるが
(1)本回答は、sort後に、前の行と比較法です
(2)同じキーをSheet2のA列でFind法なども考えられると思うが。
ーー
書式はあまり考えてない。
コードの中の、列番号の100,100は適当に修正のこと。

投稿日時 - 2020-03-26 20:23:05

お礼

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

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

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

投稿日時 - 2020-03-26 21:44:04

ANo.5

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

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

投稿日時 - 2020-03-26 19:02:13

補足

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

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

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

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

投稿日時 - 2020-03-26 19:38:46

ANo.4

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

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

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

投稿日時 - 2020-03-26 18:28:00

お礼

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

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

投稿日時 - 2020-03-26 19:30:41

ANo.3

No2です。
With Sh1.Sort
.SetRange Sh1.Range(Sh1.Cells(2, "A"), Sh1.Cells(Sh1LastRow, "G"))

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

投稿日時 - 2020-03-26 18:02:45

ANo.1

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

投稿日時 - 2020-03-26 17:02:51

補足

masnoskeさん

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

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

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


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

投稿日時 - 2020-03-26 18:49:36

あなたにオススメの質問