• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:VBA教えてください。重複データの削除)

VBAでエクセルからエクセルへの重複データ削除

このQ&Aのポイント
  • VBAを使用してエクセルからエクセルへのデータ取り込みと重複データの削除方法を教えてください。
  • 現在、エクセルの台帳とシステムから出力するcsvファイルのデータを管理しています。csvファイルのデータを台帳に追加する際、重複するデータを削除したいです。
  • 重複データの判定は、A列の通し番号で行っています。現在の方法では時間がかかっているので、より効率的な方法を教えてください。

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

  • ベストアンサー
  • kkkkkm
  • ベストアンサー率66% (1719/2589)
回答No.8

遅い場合メモリにデータを読み込んで操作するという手もあります。 操作をよく理解できていないのでとんちんかんな動作かもしれませんが たとえば以下のコードでは、多分…きっと「旧データ含む新データ」にあって「旧データA」及び「旧データB」にないものをSheet4に書き出します。それぞれA1:A2000まで検査し、ないもののA列からAZ列までのデータを書き出します。 Sub Test() Dim mData1 As Variant Dim mData2 As Variant Dim mData3 As Variant Dim mRow1 As Long, mRow2 As Long, mRow3 As Long, mCo3 As Long, mRow4 As Long Dim Flg As Boolean Dim NewData(1 To 2000, 1 To 52) As Variant mData1 = Sheets("Sheet1").Range("A1:AZ2000").Value '旧データA mData2 = Sheets("Sheet2").Range("A1:AZ2000").Value '旧データB mData3 = Sheets("Sheet3").Range("A1:AZ2000").Value '旧データ含む新データ mRow4 = 0 For mRow3 = 1 To 2000 Flg = False For mRow1 = 1 To 2000 If mData3(mRow3, 1) = mData1(mRow1, 1) Then Flg = True Exit For End If Next If Flg = False Then For mRow2 = 1 To 2000 If mData3(mRow3, 1) = mData2(mRow2, 1) Then Flg = True Exit For End If Next End If If Flg = False Then mRow4 = mRow4 + 1 For mCo3 = 1 To Columns("AZ:AZ").Column NewData(mRow4, mCo3) = mData3(mRow3, mCo3) Next End If Next Sheets("Sheet4").Range("A1:AZ2000").Value = NewData End Sub

kometoshi555
質問者

お礼

kkkkkm さん とても早く、理想通りに処理できました。 コードも理解できました。 エクセルの可能性を感じるとともに、私のやりたいことをみなさんがいっしょに考えていただたことに感激し、改めて感謝申し上げます。

その他の回答 (8)

  • m3_maki
  • ベストアンサー率64% (296/460)
回答No.9

エラー処理など思い切り手抜きですが高速です。(1秒弱くらい) Option Explicit Sub Sample()  Const staRow = 2  Dim myKey As String  Dim MaxRow As Long  Dim myDic As Object  Dim i As Long  Debug.Print "開始:" & Time$  Set myDic = CreateObject("Scripting.Dictionary")  On Error Resume Next  'シート2をディクショナリに追加  With Worksheets("Sheet2")   MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row '最終行を取得   For i = staRow To MaxRow    myKey = .Cells(i, 1)    myDic.Add myKey, myKey   Next  End With  'シート3をディクショナリに追加 With Worksheets("Sheet3")   MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row '最終行を取得   For i = staRow To MaxRow    myKey = .Cells(i, 1)    myDic.Add myKey, myKey   Next  End With  'シート1をディクショナリに追加。削除する行にマーク  With Worksheets("Sheet1")   MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row '最終行を取得   ' シート1 のみデータ開始行が異なる場合は staRow を変更(直接 5 にするとか)   For i = staRow To MaxRow    myKey = .Cells(i, 1)    '登録されていなければ登録    If Not myDic.Exists(myKey) Then     myDic.Add myKey, myKey    Else     .Cells(i, 53) = "!"    End If   Next  End With  Set myDic = Nothing  Columns(53).SpecialCells(xlCellTypeConstants, 23).EntireRow.Delete  Debug.Print "終了:" & Time$ End Sub

kometoshi555
質問者

お礼

3_maki さん とても早い処理で、理想通りの処理ができました。 Dictionaryという技術、教えていただき、ありがとうございます。

  • HohoPapa
  • ベストアンサー率65% (455/693)
回答No.7

No6の差し替えです。 シート1の中で重複があるものを除いていなかったのと 行削除した結果を格納するシートにタイトル行を出力していなかったので 差し替えます。 Sub sample()    Dim SQL As String  Dim cn As Object  Dim rs As Object  Dim RowCntI As Long  Dim RowCntP As Long  Dim shIn As Worksheet  Dim LastRow As Long  Dim tgRange As Range    'ThisWorkbook.Sheets("ログ").Cells(3, 2).Value = Now  Const MaxCol = 52 'シート1のデータ列数     'シート1の中で重複があれば行削除  With ThisWorkbook.Sheets("Sh1")   LastRow = .Cells(Rows.Count, 1).End(xlUp).Row   Set tgRange = Range(.Cells(1, 1), .Cells(LastRow, MaxCol))   tgRange.RemoveDuplicates Columns:=1, Header:=xlYes   'タイトル行を複写   .Rows(1).Copy ThisWorkbook.Sheets("Sh5").Rows(1)  End With    '/////////////////  ' Sh1シートとsh2シートをマッチングして  ' Sh4シートに出力    'SQL全文を組み立て、実行  SQL = "SELECT *" & vbCrLf  SQL = SQL & "FROM [Sh1$A2:AZ50000] A" & vbCrLf  SQL = SQL & "LEFT OUTER JOIN [Sh3$A2:B50000] B" & vbCrLf  SQL = SQL & "ON A.F1 = B.F1" & vbCrLf    Set cn = CreateObject("ADODB.Connection")  Set rs = CreateObject("ADODB.Recordset")  cn.Provider = "Microsoft.ACE.OLEDB.12.0"  cn.Properties("Extended Properties") = "Excel 12.0;HDR=No;IMEX=1"  cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name  rs.Open SQL, cn  rs.MoveFirst  RowCntI = 0  RowCntP = 0    Set shIn = ThisWorkbook.Sheets("Sh1")  Do   RowCntI = RowCntI + 1   If rs.EOF = True Then Exit Do   If IsNull(rs.Fields(MaxCol)) = True Then    RowCntP = RowCntP + 1    shIn.Rows(RowCntI + 1).Copy ThisWorkbook.Sheets("Sh4").Rows(RowCntP + 1)   End If   rs.MoveNext  Loop    rs.Close  Set rs = Nothing  cn.Close  Set cn = Nothing    '/////////////////  ' Sh4シートとsh3シートをマッチングして  ' Sh5シートに出力    'SQL全文を組み立て、実行  SQL = "SELECT *" & vbCrLf  SQL = SQL & "FROM [Sh4$A2:AZ50000] A" & vbCrLf  SQL = SQL & "LEFT OUTER JOIN [Sh2$A2:B50000] B" & vbCrLf  SQL = SQL & "ON A.F1 = B.F1" & vbCrLf    Set cn = CreateObject("ADODB.Connection")  Set rs = CreateObject("ADODB.Recordset")  cn.Provider = "Microsoft.ACE.OLEDB.12.0"  cn.Properties("Extended Properties") = "Excel 12.0;HDR=No;IMEX=1"  cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name  rs.Open SQL, cn  rs.MoveFirst  RowCntI = 0  RowCntP = 0    Set shIn = ThisWorkbook.Sheets("Sh4")  Do   RowCntI = RowCntI + 1   If rs.EOF = True Then Exit Do   If IsNull(rs.Fields(MaxCol)) = True Then    RowCntP = RowCntP + 1    shIn.Rows(RowCntI + 1).Copy ThisWorkbook.Sheets("Sh5").Rows(RowCntP + 1)   End If   rs.MoveNext  Loop    rs.Close  Set rs = Nothing  cn.Close  Set cn = Nothing  'ThisWorkbook.Sheets("ログ").Cells(4, 2).Value = Now End Sub

kometoshi555
質問者

お礼

HohoPapa さん SQL、作っていただいてありがとうございます。お時間かけていただいたことと、推測致します。 私の知識不足と学習が追い付かず、今後の維持管理が困難であることと、社内で勝手にインストールできないこともあり、現状、SQLを使用することは難しいと判断しました。 同じ部署に詳しい人がいればいいのにと思うのですが、お恥ずかしながら、私が一番詳しい状況です。これから少しずつですが、勉強して、アクセスやSQL等も使いこなせるようになりたいと思います。 この数日、考えまして、RemoveDuplicatesを1回したのちに、他シートからもってきたデータを「1」に変換し、さらにRemoveDuplicatesで消しました。15秒ほどかかるのと、プロの方が見たらびっくりするような処理かと思います(社内SEの人に怒られちゃいそうです)が、現状致し方ないです。 アドバイスいただき、お時間いただき、ありがとうございました。 心から感謝致します。

  • HohoPapa
  • ベストアンサー率65% (455/693)
回答No.6

SQLを持ち出せば、 ハードルが少々上がりますし、制限もありますが 少なくとも私の環境では7~8秒で期待の処理ができます。 1行目がタイトル行 シート1,2,3ともA列が商品コード シート1,2,3ともA,B列の途中に空欄のセルがない という条件でよければ、以下のコードをよかったら試してください。 なお、シート名は シート1:Sh1 シート2:Sh2 シート3:Sh3 作業シート:Sh4 行削除の行われた結果を格納するシート:Sh5です。 Sub sample()    Dim SQL As String  Dim cn As Object  Dim rs As Object  Dim RowCntI As Long  Dim RowCntP As Long  Dim shIn As Worksheet    'ThisWorkbook.Sheets("ログ").Cells(3, 2).Value = Now    '/////////////////  ' Sh1シートとsh2シートをマッチングして  ' Sh4シートに出力    'SQL全文を組み立て、実行  SQL = "SELECT *" & vbCrLf  SQL = SQL & "FROM [Sh1$A2:AZ50000] A" & vbCrLf  SQL = SQL & "LEFT OUTER JOIN [Sh3$A2:B50000] B" & vbCrLf  SQL = SQL & "ON A.F1 = B.F1" & vbCrLf    Set cn = CreateObject("ADODB.Connection")  Set rs = CreateObject("ADODB.Recordset")  cn.Provider = "Microsoft.ACE.OLEDB.12.0"  cn.Properties("Extended Properties") = "Excel 12.0;HDR=No;IMEX=1"  cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name  rs.Open SQL, cn  rs.MoveFirst  RowCntI = 0  RowCntP = 0    Set shIn = ThisWorkbook.Sheets("Sh1")  Do   RowCntI = RowCntI + 1   If rs.EOF = True Then Exit Do   If IsNull(rs.Fields(52)) = True Then    RowCntP = RowCntP + 1    shIn.Rows(RowCntI + 1).Copy ThisWorkbook.Sheets("Sh4").Rows(RowCntP + 1)   End If   rs.MoveNext  Loop    rs.Close  Set rs = Nothing  cn.Close  Set cn = Nothing    '/////////////////  ' Sh4シートとsh3シートをマッチングして  ' Sh5シートに出力    'SQL全文を組み立て、実行  SQL = "SELECT *" & vbCrLf  SQL = SQL & "FROM [Sh4$A2:AZ50000] A" & vbCrLf  SQL = SQL & "LEFT OUTER JOIN [Sh2$A2:B50000] B" & vbCrLf  SQL = SQL & "ON A.F1 = B.F1" & vbCrLf    Set cn = CreateObject("ADODB.Connection")  Set rs = CreateObject("ADODB.Recordset")  cn.Provider = "Microsoft.ACE.OLEDB.12.0"  cn.Properties("Extended Properties") = "Excel 12.0;HDR=No;IMEX=1"  cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name  rs.Open SQL, cn  rs.MoveFirst  RowCntI = 0  RowCntP = 0    Set shIn = ThisWorkbook.Sheets("Sh4")  Do   RowCntI = RowCntI + 1   If rs.EOF = True Then Exit Do   If IsNull(rs.Fields(52)) = True Then    RowCntP = RowCntP + 1    shIn.Rows(RowCntI + 1).Copy ThisWorkbook.Sheets("Sh5").Rows(RowCntP + 1)   End If   rs.MoveNext  Loop    rs.Close  Set rs = Nothing  cn.Close  Set cn = Nothing  'ThisWorkbook.Sheets("ログ").Cells(4, 2).Value = Now End Sub

  • kkkkkm
  • ベストアンサー率66% (1719/2589)
回答No.5

> シート(1)に(2)、(3)のデータからA列のみをコピーして貼っておき、そこに、csvデータを張り付け、その上で、RemoveDuplicatesを行う。 > 残ったもののなかで、A列以外にも値が入っているのが、新規データなので、ループして、A列のみの行を削除する。 ループで行の削除が時間がかかっているという気もするのですが、データがどのようになっているのか頭悪くて分からないのですが想像だと シート(1)をシート(2)の末尾にすべてコピー、すべての列範囲指定で重複列をA列指定での削除 (シート(1)での新規データ以外は削除され新規データのみコピーしたことになる) シート(2)をシート(3)の末尾にすべてコピー、すべての列範囲指定で重複列をA列指定での削除 (シート(2)での新規データ以外は削除され新規データのみコピーしたことになる) だと駄目なのでしょうか。

kometoshi555
質問者

お礼

「ループで行の削除が時間がかかっているという気もする」というご指摘、そうですね。ここが問題なのを忘れていました。 なかなか文面で伝えるのが難しく、実際のものを見ていただける環境にあればいいのにと、また、kkkkkm さんのような方が社内にいればいいのにほんとうに思うのですが……。 シート(2)、シート(3)は進捗管理で使用しているので、元のデータのまま残したいのです。 この数日、考えまして、ループで削除をやめ、ループで値の置き換えならそんなに時間がかからない(?)ような気がして、RemoveDuplicatesを1回したのちに、他シートからもってきたデータを「1」に変換し、さらにRemoveDuplicatesで消しました。15秒ほどかかるのと、プロの方が見たらびっくりするような処理かと思いますが、現状致し方ないです。 アドバイスいただき、ありがとうございました。

  • HohoPapa
  • ベストアンサー率65% (455/693)
回答No.4

>‘csvファイル:商品コード、商品名、注文日、納期、などなどA~AZ列まで、 >1行目は項目名で、その後、1行1商品で2000行ほどデータがあります。 この記述からデータは2行目から開始しているように思えますが、 >For i = 5000 To 5 Step -1 と >Range("BA5") = >"IF(A5="""","""",COUNTIF($A$4:$A5,A5)+COUNTIF((2)!$A:$A,A5)+COUNTIF((3)!$A:$A,A5))" からは、シート1,2,3とも データは5行目?、4行目?から始まっているように読み取れます。 提示されたコードでは、シート1の52列目に計算式を埋め その計算結果をみて、行削除するかどうか判定しているわけですが むしろ、その判定をVBAで行ったほうが早いと思います。 それでもレコードごとに、重複が見つかるまで総当たりしていますので 10秒を下回れるかどうか怪しいですが よかったら参考に挑戦してみてください。 Sub sample()  Dim LastRow As Long  Dim tgRange As Range  Dim i As Long  Const stRow = 2  'シート1のデータ開始行  Const MaxCol = 51 'シート1のデータ列数  With ThisWorkbook.Sheets(1)     'シート1の中で重複があれば行削除   LastRow = .Cells(Rows.Count, 1).End(xlUp).Row   Set tgRange = Range(.Cells(1, 1), .Cells(LastRow, MaxCol))   tgRange.RemoveDuplicates Columns:=1, Header:=xlYes    'シート2,3に同じ商品コードがあったら行削除   LastRow = .Cells(Rows.Count, 1).End(xlUp).Row   For i = LastRow To stRow Step -1    If isHit(.Cells(i, 1).Value) = True Then     .Rows(i).Delete    End If   Next i     '行高設定   LastRow = .Cells(Rows.Count, 1).End(xlUp).Row   .Range(Rows(2), Rows(LastRow)).RowHeight = 15.75  End With End Sub '//重複かどうかの判定関数 Function isHit(SCode As String) As Boolean  Dim RowCnt As Long  Const stRow2 = 2 'シート2のデータ開始行  Const stRow3 = 2 'シート3のデータ開始行  isHit = False    With ThisWorkbook.Sheets(2)   RowCnt = stRow2   Do    If .Cells(RowCnt, 1).Value = "" Then Exit Do    If .Cells(RowCnt, 1).Value = SCode Then     isHit = True     Exit Function    End If    RowCnt = RowCnt + 1   Loop  End With    With ThisWorkbook.Sheets(3)   RowCnt = stRow3   Do    If .Cells(RowCnt, 1).Value = "" Then Exit Do    If .Cells(RowCnt, 1).Value = SCode Then     isHit = True     Exit Function    End If    RowCnt = RowCnt + 1   Loop  End With End Function

kometoshi555
質問者

お礼

HohoPapa さん ありがとうございます。 詳細に読み解いていただいて、作成いただき、ありがとうございました。 実際に動かしてみて、やりたいことはできました。 最初と最後に画面を止めるコード等を入れたのですが、HohoPapa さんもご指摘の通り、総当たりでデータ数が多いためか、30秒ほどかかってしまいました。 HohoPapa さんや、kkkkkmさんが使っているRemoveDuplicatesが早いように思うので、 シート(1)に(2)、(3)のデータからA列のみをコピーして貼っておき、そこに、csvデータを張り付け、その上で、RemoveDuplicatesを行う。 残ったもののなかで、A列以外にも値が入っているのが、新規データなので、ループして、A列のみの行を削除する。 というのを一度やってみて、時間比較しようと思います。 貼ったり、消したり、時間かかりますでしょうか。 一度試してみます。

  • imogasi
  • ベストアンサー率27% (4737/17069)
回答No.3

質問文の説明がごちゃごちゃして、要点を説明できてないと思う。 まずVBAコードなど掲示する以前の問題と思う。 VBAというよりも、(データ処理の)処理ロジック(処理パターン)を、経験を踏んで、豊富にする、訓練する必要があると思う。 >新規データのみを台帳に追加していきたいです。 やりたいことを、一言で言えば、これだろう。 >標題の、「重複データの削除 」(したい)と銘打つのはピント外れと思う。 どちらかと言えば、「更新」の処理にアラルのだろうと思う。 ーー それには、最低でもMSAccess(アクセス)などの(RDBS)データべーを扱えるものを勉強すべきだ。 他の方法としては、ファイルの結合ロジックを使って(VBAを組んで)やれば、新規かどうか判別できるだろう。  どうしてもDBソフトを使わないなら、新規データとCSVデータを(同じ)キー項目でソートし、Mathingのアルゴリズムで突合し、新規データを見つけることができる。一件ずつ検索では処理時間がかかりすぎるだろうから。 ーー  昔は、マスターデータとトランザクションデータという考え(や処理方法)を叩き込まれたものだが、そういうことをどこかで勉強しましたか(これは、エクセルの使い方などではない分野でしょう)?周りに、大きく、教えてもらえる先輩はいますか。今回コードをコピペして解決しても、いろいろな点で、仕事でデータ処理するのはすぐ別の問題にぶち当たるだろう。

kometoshi555
質問者

お礼

imogasi さん ありがとうございます。 説明がごちゃごちゃしており、申し訳ありません。 できるだけやりたいことの詳細と、今考えていることとを伝えようと思ったのですが……的外れだったようです。 SEの方、ロジカルなところ、日々の生活のなかでも生かせそうで、いいですね。 >新規データとCSVデータを(同じ)キー項目でソートし、Mathingのアルゴリズムで突合し、新規データを見つけることができる これはエクセルでもできるのでしょうか。 >昔は、マスターデータとトランザクションデータという考え(や処理方法)を叩き込まれたものだが、そういうことをどこかで勉強しましたか(これは、エクセルの使い方などではない分野でしょう)?周りに、大きく、教えてもらえる先輩はいますか。 全くの独学で、必要時にネットで調べたり、サイトで質問して教えていただいて、なんとかやっている状態です。マスターデータとトランザクションデータという考えはわかりません。社内にSEが一人いるのですが、200人くらいの社員に対して一人なので、細かいところまで見てもらうことができず、自分でするしかない状況です。 現状、作業に手間がかかり、ミスが頻発するような現状を放っておくこともできず、私のような素人がなんとかしなきゃと取り組んでいます。そうすると、中途半端に楽にはなるのですが、それが本当にいいのか、葛藤もあります。 しばらくは大変だけど、放っておいて、イチからプロに見ていただいたほうが、長期的にはいいのかとも思うのですが、難しい問題だと感じています。

  • kkkkkm
  • ベストアンサー率66% (1719/2589)
回答No.2

エクセルの機能に重複の削除がありますのでそちらのコードをマクロの記録で取得してやってみてはいかがでしょう。 単純なものだとこんな感じのコードになります。 ActiveSheet.Range("$A$5:$A$9").RemoveDuplicates Columns:=1, Header:=xlNo あと、蛇足になりますが、‘行幅を整えるでは、.Selectを省略してもいいと思います。今回の場合では時間とはほとんど関係はないと思いますが。.Selectも多くなると時間に関係してくるとは思います。 Range(Rows("5:5"), Rows("5:5").End(xlDown)).RowHeight = 15.75

kometoshi555
質問者

お礼

kkkkkmさん ありがとうございます。 RemoveDuplicates だとシートをまたいでの設定ができなくて、諦めていたのですが、 シート(1)に(2)、(3)のデータからA列のみをコピーして貼っておき、そこに、csvデータを張り付け、その上で、RemoveDuplicatesを行う。 残ったもののなかで、A列以外にも値が入っているのが、新規データなので、ループして、A列のみの行を削除する。 というのを一度やってみて、時間比較しようと思います。 ‘行幅を整えるところ、さっそく修正しました。 ありがとうございます。

  • bardfish
  • ベストアンサー率28% (5029/17766)
回答No.1

RDBほ併用すると非常に簡単になると思いますよ。 Microsoft SQLServer Expressは無料で利用できます。 で、列の内容が不明なので具体例を示すことが出来ませんが、SQLなら重複業を取り除いたデータの抽出ならSQL文1行で作れるかもしれません。 Transact-SQLを作ってSQLServer内で抽出後のテーブルを作り、そのテーブルをExcelに取り込む・・・私ならその方法を取ります。 Excel VBAでSQLを発行して1行ずつ取り込むという方法でもいいと思います。 Microsoft SQLServer Managment StudioでSQLを実行しても同じことが出来るかもしれませんけど試したことないです。 RDBはインデックスの張り方とSELECT文での抽出条件の書き方次第で抽出完了の時間が大きく変わります。これはAccessでも同じです。 Excelはシートに記入するデータが増えると動作そのものが遅くなってきます。ですがデータベースを使用すれば5000件のデータが500万件になってもフロントエンドとしてのソフトの操作自体に影響はありません。せいぜい同じデータ抽出に時間がかかる程度ですが、それでも非常に高速です。 Excelでデータ処理のプログラムを引き継いでAccessに移植したら処理に必要な時間が5分の1に短縮しました。 プログラムも非常に煩雑で、簡単な仕様変更にもプログラム修正が非常に大変な作り方だったので、要求されるであろう仕様変更(抽出条件の変更、追加)を指示画面で指定できるように改造しました。

kometoshi555
質問者

お礼

bardfish さん ありがとうございます。 RDB、Accessだと楽なのですね。 会社内で、RDB、Accessのインストールに許可をとるのが大変なのと、 エクセルしか使わないようなところなので、今後の使用や、修正などを考えると、導入は難しそうです。 まずはエクセルでできる方法でできるだけ所要時間の削減を図り、新しいもの(アクセス等)を導入するのか、検討したいと思います。 その際はまた教えてください。