| |
>おはようございます。
>早速、シート名とコード名を差し替えて試してみたのですが
>「Keyが重複しています。」
>と表示され、Dコードは振られませんでした。。。
>どうしたらいいのでしょうか？
>元データにはA・B・Cコードが同じのもが複数あるからでしょうか？
Sheet2に、Aコード且つ、Bコード且つ、Cコードの物が複数ある場合
このメッセージを出して終了する様に就くって有ります
Sheet2に、Aコード且つ、Bコード且つ、Cコードの物の、
Dコードが違っているなら、コードの振り直しは出来ないのでは？（一意になら無い為）
Dコードが同じなら、以下の様に成ります
Option Explicit
Public Sub Sample2()
Dim i As Long
Dim vntData As Variant
Dim lngRows As Long
Dim rngResult As Range
Dim strResult() As String
Dim dicIndex As Object
Dim vntKey As Variant
Dim strProm As String
'Sheet2のList先頭セルを指定（列見出しの左上隅）
With Worksheets("Sheet2").Cells(1, "A")
'データ行数を取得
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
'Dコードが違うなら
If .Item(vntKey) <> vntData(i, 4) Then
strProm = "Keyが重複しています"
GoTo Wayout
End If
Else
'KeyとDコードをIndexに登録
.Add vntKey, vntData(i, 4)
End If
Next i
End With
'Sheet1のList先頭セルを指定（列見出しの左上隅）
Set rngResult = Worksheets("Sheet1").Cells(1, "A")
With rngResult
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
vntData = .Offset(1).Resize(lngRows, 3).Value
End With
'結果用配列を確保
ReDim strResult(1 To lngRows, 1 To 1)
'Sheet1のKeyをIndexから探索
With dicIndex
For i = 1 To lngRows
vntKey = vntData(i, 1) & vbTab _
& vntData(i, 2) _
& vbTab & vntData(i, 3)
'Keyが有ったら結果用配列に代入
If .Exists(vntKey) Then
strResult(i, 1) = .Item(vntKey)
End If
Next i
End With
'結果を出力
With rngResult
.Offset(1, 3).Resize(lngRows).Value = strResult
End With
strProm = "処理が完了しました"
Wayout:
Set dicIndex = Nothing
Set rngResult = Nothing
Beep
MsgBox strProm
End Sub
|
|
Hirofumi
- 05/6/10(金) 21:36 -
