VBA：Excel ：検索（重複/重複でない セルをRangeで取得）

UserFormでlistBoxにシート名を表示
選択したシートに処理

【MAIN】

Private Sub mth_Main()

    '============================
    '// WorkSheet
    '============================
    Dim ListNo As Long
    ListNo = Me.lst_Sht.ListIndex
    If ListNo < 0 Then
        MsgBox "いずれかの行を選択してください"
        Exit Sub
    End If
    
    Dim ws As Worksheet
    Set ws = Workbooks(txt_FileOpen_RO.Text).Worksheets(Me.lst_Sht.List(ListNo))
    
    '----------------------
    '// 全Trim
    '----------------------
    Dim v
    For Each v In ws.UsedRange
        v.Value = Trim(v.Value)
    Next
    
    '========================================
    '// 重複/重複でない Range取得
    '========================================
    ws.Cells.Interior.Color = RGB(255, 255, 255)
    Dim iCols() As Long
    ReDim iCols(2)
    iCols(0) = 4
    iCols(1) = 6
    iCols(2) = 8
    
    Dim iRow_Last As Long
    iRow_Last = ws.Cells(ws.Rows.Count, iCols(0)).End(xlUp).Row
    
    Dim iRow_Start As Long
    iRow_Start = 2
    
    Dim rngDuplicateOrNat As Range
'    Set rngDuplicateOrNat = mth_GetDuplicateOrNotRng(ws, iRow_Start, iRow_Last, iCols, False)   '// 重複でない
    Set rngDuplicateOrNat = mth_GetDuplicateOrNotRng(ws, iRow_Start, iRow_Last, iCols, True)     '// 重複
        
    If Not rngDuplicateOrNat Is Nothing Then
        rngDuplicateOrNat.Interior.Color = RGB(192, 192, 0)
    End If
    
    Set rngDuplicateOrNat = Nothing
    Set ws = Nothing
    
End Sub

【処理MAIN】

'**
'* 重複/重複でない セルをRangeで取得
'* 指定範囲（指定行(開始/終了)、指定列(複数)）の重複/重複でない セルをRangeで取得
'*
'* @param   ws {Worksheet}      WorkSheet
'* @param   lRow_Start {Long}   開始行
'* @param   lRow_End {Long}     終了行
'* @param   iCols {Long()}      対象列リスト
'* @param   bDuplicate {bool}   True:重複検索 / False:重複でない検索
'* @return  {Range}             検出Range
'*
Public Function mth_GetDuplicateOrNotRng( _
                                        ws As Worksheet, _
                                        lRow_Start As Long, _
                                        lRow_End As Long, _
                                        iCols() As Long, _
                                        bDuplicate As Boolean _
                                        ) As Range
        
    Dim rngDupOrNot As Range   '// 重複/重複でない Range
    
    '// 汎用変数
    Dim r As Long, c As Long
    Dim v
    
    '=========================================================
    '// 行ごとに各列を結合して、検索対象リスト配列を作成
    '=========================================================
    Dim sCheckList_Rows() As String
    Dim lCheckList_Cnt As Long
    For r = lRow_Start To lRow_End
    
        Dim sCheckList As String
        sCheckList = ""
        For c = LBound(iCols) To UBound(iCols)
            sCheckList = sCheckList & ws.Cells(r, iCols(c))
        Next c
        
        ReDim Preserve sCheckList_Rows(lCheckList_Cnt)
        sCheckList_Rows(lCheckList_Cnt) = sCheckList
        lCheckList_Cnt = lCheckList_Cnt + 1
    Next r
                                    
    '=========================================================
    '// 行ごとに検索
    '=========================================================
    Dim lDupOrNot_Rows()   As Long     '重複/重複でない 行番号リスト
    Dim lDupOrNot_Cnt      As Long     '重複/重複でない 数
    
    lDupOrNot_Cnt = 0
    For r = lRow_Start To lRow_End
        
        '// 検索用に文字列結合
        Dim sCheckString As String
        sCheckString = ""
        For c = LBound(iCols) To UBound(iCols)
            sCheckString = sCheckString & ws.Cells(r, iCols(c))
        Next c
                
        '// 完全一致を検索
        Dim cltFind_Idx As Collection
        Set cltFind_Idx = mth_GetStrComp(sCheckList_Rows, sCheckString, True)
        
        '// 検索結果(重複/重複でない)
        If (bDuplicate = True And cltFind_Idx.Count > 1) _
        Or (bDuplicate = False And cltFind_Idx.Count = 1) _
        Then
            '// 検索条件（重複)      ：cltFind_Idx 2つ以上
            '// 検索条件（重複でない)：cltFind_Idx 1つ
            ReDim Preserve lDupOrNot_Rows(lDupOrNot_Cnt)
            lDupOrNot_Rows(lDupOrNot_Cnt) = r
            lDupOrNot_Cnt = lDupOrNot_Cnt + 1
        Else
            ' 検索条件外
        End If
    Next r
    
    '// 該当（重複/重複でない)がなければ終了
    If lDupOrNot_Cnt = 0 Then GoTo END_PROC
    
    '// Range設定
    lDupOrNot_Cnt = 0
    For Each v In lDupOrNot_Rows
        For c = LBound(iCols) To UBound(iCols)
            If lDupOrNot_Cnt = 0 And c = 0 Then
                Set rngDupOrNot = ws.Cells(v, iCols(c))
            Else
                Set rngDupOrNot = Union(rngDupOrNot, ws.Cells(v, iCols(c)))
            End If
        Next c
        
        lDupOrNot_Cnt = lDupOrNot_Cnt + 1
    Next v
    
END_PROC:
    Set mth_GetDuplicateOrNotRng = rngDupOrNot

End Function

【比較処理(StrComp)】

'**
'* 文字列配列から指定文字列のINDEXを取得する
'*
'* @param   sCheckLists {String()}  検索対象配列
'* @param   sCheckString {String}   検索文字列
'* @param   bSame {bool}            True:完全一致 / False:相違
'* @return  {Collection}            検出Index
'*
Public Function mth_GetStrComp( _
                                sCheckLists() As String, _
                                sCheckString As String, _
                                bCompMode_Same As Boolean _
                                ) As Collection
        
    Dim i As Long
    
    Dim cltFind_Idx As Collection
    Set cltFind_Idx = New Collection

    Dim lFind_Cnt As Long
    
    For i = LBound(sCheckLists) To UBound(sCheckLists)
        Dim lCompRes As Long
        lCompRes = StrComp(sCheckLists(i), sCheckString)
        
        If (bCompMode_Same And lCompRes = 0) _
        Or (bCompMode_Same = False And lCompRes <> 0) _
        Then
             cltFind_Idx.Add i
             lFind_Cnt = lFind_Cnt + 1
        End If
            
    Next i

    Set mth_GetStrComp = cltFind_Idx
        
End Function