| |
どのシートから探して、どのシートのどの列に書き込むのか解らないので？
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
|
|
Hirofumi
- 05/6/9(木) 21:05 -
