| |
Sheet1(Dコードの有るList）の重複を検査します
重複が有る場合、Sheet3に結果を表示します
登録行"とは、最初に出てきた行位置で、
"重複行"とは、重複して出てきた行位置を示します
Option Explicit
Public Sub Examination()
Dim i As Long
Dim j As Long
Dim vntData As Variant
Dim lngRows As Long
Dim lngRow As Long
Dim rngResult As Range
Dim vntResult As Variant
Dim dicIndex As Object
Dim vntKey As Variant
Dim strProm As String
Dim lngOffset As Long
'検査結果を出力するSheetを設定
Set rngResult = Worksheets("Sheet3").Cells(1, "A")
With rngResult.Resize(, 10)
.Value = Array("登録行", "Aコード", "Bコード", "Cコード", "Dコード", _
"重複行", "Aコード", "Bコード", "Cコード", "Dコード")
End With
'検査結果出力用配列を確保
ReDim vntResult(1 To 1, 1 To 10)
lngRow = 1
'Sheet1(Dコードの有るList）のList先頭セルを指定（列見出しの左上隅）
With Worksheets("Sheet1").Cells(1, "A")
'Offset量
lngOffset = .Row - 1
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Offset(1).Resize(lngRows, 4).Value
End With
'Dictionaryオブジェクトのインスタンスを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'Indexを作成
With dicIndex
'データ全てに繰り返し
For i = 1 To lngRows
'Aコード、Bコード、CコードをKeyとする
vntKey = vntData(i, 1) & vbTab _
& vntData(i, 2) _
& vbTab & vntData(i, 3)
'もしKeyが重複する場合
If .Exists(vntKey) Then
vntResult(1, 1) = .Item(vntKey)
vntResult(1, 6) = i + lngOffset
For j = 1 To 4
vntResult(1, j + 1) = vntData(vntResult(1, 1), j)
vntResult(1, j + 6) = vntData(i, j)
Next j
With rngResult.Offset(lngRow).Resize(, 10)
.NumberFormatLocal = "@"
.Value = vntResult
End With
lngRow = lngRow + 1
Else
'KeyとDコードをIndexに登録
.Add vntKey, i + lngOffset
End If
Next i
End With
strProm = "処理が完了しました"
Wayout:
Set dicIndex = Nothing
Set rngResult = Nothing
Beep
MsgBox strProm
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
