|
▼Hirofumi さん:
>どのシートから探して、どのシートのどの列に書き込むのか解らないので?
>Sheet1、Sheet2が以下の様で、Sheet1のAコード、Bコード、Cコードを
>Sheet2因り探索して、Sheet1のD列に書きこむとしています
>
>Sheet1
> A B C
> 1 Aコード Bコード Cコード
> 2 00001 001 010
> 3 00001 002 010
> 4 00002 001 010
> 5 ・ ・ ・
>
>Sheet2
> A B C D
> 1 Aコード Bコード Cコード Dコード
> 2 00001 001 010 001
> 3 00001 002 010 001
> 4 00002 001 010 002
> 5 ・ ・ ・ ・
>
>Option Explicit
>
>Public Sub Sample()
>
> 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
> strProm = "Keyが重複しています"
> GoTo Wayout
> 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
おはようございます。
早速、シート名とコード名を差し替えて試してみたのですが
「Keyが重複しています。」
と表示され、Dコードは振られませんでした。。。
どうしたらいいのでしょうか?
元データにはA・B・Cコードが同じのもが複数あるからでしょうか?
|
|