Excelへcsvを取込む前に既存データとの重複チェックを行う方法を教えてください

Question

前提・実現したいこと

excelにcsvデータを追記で取込むときに、すでに登録されている指定列”G”と”O”のデータと重複チェックを行い
重複がある場合は、エラーリスト（別シート）に出力、重複がない場合はcsv取り込みを進めるようなVBAを書きたいのですが、
どのようにしたらよいか、お知恵をお貸しください。（最近VBAを触り始めました）

該当のソースコード

素人ながらに現状、下記コードを書いています。

Sub cmdBtn_Csv_Import()
Dim myFileName As Variant
Dim Fcn As Long
Dim i As Long
Dim buf As String
Dim tmp As Variant
Dim n, m, h As Long

' csvファイル選択
myFileName = Application.GetOpenFilename("CSVファイル(*.csv),*.csv", _
                                                                      Title:="CSVファイルの選択")
If myFileName = False Then
      MsgBox "キャンセルされました。"
      Exit Sub
      
End If

' イベント停止
Application.DisplayAlerts = False
Call EventTermination

With Worksheets("Sheet1")
' 最終行を取得
    n = .Cells(.Rows.Count, 4).End(xlUp).Row
    
    If INT_ROW_DATAHEAD_START <= 5 Then
    End If

' 重複チェック
Set ws1 = Worksheets("Sheet1")
Workbooks.Open FileName:=myFileName
Set ws2 = ActiveWorkbook.Worksheets()
For m = 5 To n
    For h = 2 To 200
    If ws2.Range("G", h).Value = ws1.Range("G", m).Value Then
        MsgBox "重複データがあります"
    Exit Sub
        Exit For
    End If
    Next
Next

'書き出し
Open myFileName For Input As #1
    Line Input #1, buf
    Do Until EOF(1)
        Line Input #1, buf
        Fcn = Fcn + 1
        tmp = Split(buf, ",")
        n = n + 1
            ws1.Cells(n, 4).Value = tmp(2)
            ws1.Cells(n, 5).Value = tmp(3)
            ws1.Cells(n, 6).Value = tmp(4)
            ws1.Cells(n, 7).Value = tmp(6)
            ws1.Cells(n, 8).Value = tmp(7)
            ws1.Cells(n, 9).Value = tmp(8)
            ws1.Cells(n, 10).Value = tmp(9)
            ws1.Cells(n, 11).Value = tmp(10)
            ws1.Cells(n, 12).Value = tmp(11)
            ws1.Cells(n, 13).Value = tmp(14)
            ws1.Cells(n, 14).Value = tmp(12)
            ws1.Cells(n, 15).Value = tmp(13)
        Loop
    Close #1
   
' イベント開始
Application.DisplayAlerts = True
Call EventRestart
ThisWorkbook.Activate
        
        MsgBox "処理が完了しました。"
 ws1.Activate

End With
End Sub

Comments

[hatena19]

> 指定列”G”と”O”のデータと重複チェック

G列またはO列のどちらか一方でも重複してたらエラーでしょうか。
それともG列とO列の組み合わせで、重複していた場合にエラーでしょうか。

[shhan0704]

G列とO列の組み合わせで重複していた場合にエラーにしたいです。

Answer 1

Dictionaryを使った方法は既にでてますので、
AdvancedFilterを使った方法を紹介しておきます。

    Dim ws1 As Worksheet '取り込み先
    Dim ws2 As Worksheet 'CSV
    Dim ws3 As Worksheet 'エラー
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Workbooks.Open(myFileName)
    Set ws3 = Workbooks.Add.Worksheets(1)

    Dim rngMoto As Range
    Set rngMoto = ws1.Cells(1, 1).CurrentRegion
    Dim rngCSV As Range
    Set rngCSV = ws2.Cells(1, 1).CurrentRegion
    Dim rngCriteria As Range
    Set rngCriteria = ws3.Cells(1, 1).Resize(rngMoto.Rows.Count, 2)
    rngCriteria.Columns(1).Value = rngMoto.Columns("B").Value
    rngCriteria.Columns(2).Value = rngMoto.Columns("D").Value
    'CSVデータに取りこみ先のG列、O列でフィルタをかける
    rngCSV.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCriteria
    rngCriteria.Clear
    With rngCSV.SpecialCells(xlCellTypeVisible) '重複データを
        .Copy ws3.Cells(1, 1)                   'エラーシートにコピー
        .EntireRow.Delete                       '削除
    End With
    ws2.ShowAllData 'フィルター解除
    ws2.Cells(1, 1).CurrentRegion.Copy _
        ws1.Cells(rngMoto.Rows.Count + 1, 1) '取り込み先に追加コピー

Answer 2

たとえばこんな感じでどうでしょうか。

    Dim ws1 As Worksheet '取り込み先
    Dim ws2 As Worksheet 'CSV
    Dim ws3 As Worksheet 'エラー
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = Workbooks.Open(myFileName).Worksheets(1)
    Set ws3 = Workbooks.Add.Worksheets(1)
    
    Dim dic
    Set dic = CreateObject("Scripting.Dictionary")
    
    With ws1
        Dim i, n
        n = .Range("D" & .Rows.Count).End(xlUp).Row
        For i = 2 To n
            dic(.Range("G" & i).Value & vbTab & .Range("O" & i).Value) = 0
        Next
    End With

    With ws2
        Dim e
        For i = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            If dic.Exists(.Range("G" & i).Value & vbTab & .Range("O" & i).Value) Then
                e = e + 1
                .Rows(i).Copy ws3.Rows(e)
            Else
                n = n + 1
                .Rows(i).Copy ws1.Rows(n)
                dic(.Range("G" & i).Value & vbTab & .Range("O" & i).Value) = 0
            End If
        Next
    End With

---

＜追記＞
意外とこんな感じでもいいのかも。

    Dim i
    For i = 2 To ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
        If WorksheetFunction.CountIfs(ws1.Range("G:G"), ws2.Range("G" & i).Value, ws1.Range("O:O"), ws2.Range("O" & i).Value) = 0 Then
            ws2.Rows(i).Copy ws1.Range("A" & ws1.Rows.Count).End(xlUp).Offset(1)
        Else
            ws2.Rows(i).Copy ws3.Range("A" & ws3.Rows.Count).End(xlUp).Offset(1)
        End If
    Next

Comments

[shhan0704]

ありがとうございます。
試してみたいと思います。結果をまたご報告します。

[shhan0704]

ご親切にありがとうございました。無事うまく動作させることができました。
ありがとうございます。