Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

55804 / 76732

←次へ　｜　前へ→


	【25695】Re:３つのｺｰﾄﾞと合致するデータに新しいコードを振る方法

Hirofumi - 05/6/11(土) 0:13 -


	引用なし

	パスワード

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

0 hits

▼

【25644】３つのｺｰﾄﾞと合致するデータに新しいコードを振る方法 Lee 05/6/9(木) 11:19