MW211 EXIT

devlog
ExcelVBA/複合キー重複チェック
2017年06月21日
単一キーの重複チェックは「COUNTIF()」などを駆使すれば一発だが
複合キーとなると中々めんどくさい。
一番簡単なのは、複合キーを文字列として結合し
単一キーにした上でチェックとなるのだが、どうも煩雑だ。

ということで、マクロで実装を試みた。
選択した範囲内で特定の列(変数で指定)の複合キー重複チェックを行う例。
┌──────────────────────────────────────┐
│'===========================================================================
│'  複合キー重複チェック                                                     
│'===========================================================================
│Public Sub 複合キー重複チェック()
│    Const X第一キー As Long = 1      '照合キー1の列(値は任意)
│    Const X第二キー As Long = 2      '照合キー2の列(値は任意)
│    Const X第三キー As Long = 3      '照合キー3の列(値は任意)
│    Const X出力     As Long = 0      '結果出力列(値は任意)
│    Dim y As Long, y検索 As Long
│    Dim is重複 As Boolean
│    Dim obj検索 As Range, 検索範囲 As Range
│    Application.ScreenUpdating = False
│    ActiveWorkbook.EnableAutoRecover = False
│    With Selection
│        Range(.Cells(1, X出力), .Cells(.Rows.count, X出力)).ClearContents
│        For y = 1 To .Rows.count - 1
│            If .Cells(y, X第一キー).Value <> "" Then
│                If .Rows(y).Row Mod 100 = 0 Then
│                    DoEvents
│                    Application.StatusBar = .Rows(y).Row
│                End If
│                If .Cells(y, X出力).Value = "" Then
│                    If WorksheetFunction.CountIf( _
│                        Range(.Cells(y + 1, X第一キー), .Cells(.Rows.count, X第一キー)), _
│                        .Cells(y, X第一キー).Value _
│                    ) > 0 Then
│                        is重複 = False
│                        Set 検索範囲 = Range(.Cells(y, X第一キー), .Cells(.Rows.count, X第一キー))
│                        Set obj検索 = 検索範囲.Find( _
│                            What:=.Cells(y, X第一キー).Value, _
│                            After:=.Cells(y, X第一キー), _
│                            LookIn:=xlValues, _
│                            LookAt:=xlWhole, _
│                            SearchOrder:=xlByRows, _
│                            SearchDirection:=xlNext, _
│                            MatchCase:=True, _
│                            MatchByte:=True _
│                        )
│                        Do Until obj検索.Address = .Cells(y, X第一キー).Address
│                            y検索 = obj検索.Row - .Rows(1).Row + 1
│                            If .Cells(y検索, X第二キー).Value = .Cells(y, X第二キー).Value _
│                            And .Cells(y検索, X第三キー).Value = .Cells(y, X第三キー).Value Then
│                                .Cells(y検索, X出力).Value = "重"
│                                is重複 = True
│                            End If
│                            Set obj検索 = 検索範囲.FindNext(obj検索)
│                        Loop
│                        If is重複 Then
│                            .Cells(y, X出力).Value = "重"
│                        End If
│                    End If
│                End If
│            End If
│        Next y
│    End With
│    Application.StatusBar = False
│    ActiveWorkbook.EnableAutoRecover = True
│    Application.ScreenUpdating = True
│End Sub
└──────────────────────────────────────┘
分類:ExcelVBA