| |
>昨日の続きで
>コードを2つに減らして試してみましたが､
>上手くいきません｡｡｡
>どこがおかしいのでしょうか？
上手く行かない時は、どの部分がどの様に上手く行かないかを書かないと
上手く行かない理由が解らないよ（環境の相異等も関係する場合も有りますので）
多分、今回のは、★印の部分がエラーに成っていると思いますけど？
Option Explicit
Public Sub Sample3()
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, 3).Value
End With
'Dictionaryオブジェクトのインスタンスを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'Indexを作成
With dicIndex
'データ全てに繰り返し
For i = 1 To lngRows
'Aコード、Bコード をKeyとする ★この行不正
' vntKey = vntData(i, 1)
' & vbTab & vntData(i, 2)
'★不正理由
'行継続文字（_)アンダースコアが無いのに改行している
'行継続文字を無くして1行にするか、行継続文字を入れる
vntKey = vntData(i, 1) & vbTab & vntData(i, 2)
'もしKeyが重複する場合
If .Exists(vntKey) Then
strProm = "Keyが重複しています"
GoTo Wayout
Else
'KeyとcｺｰドをIndexに登録
.Add vntKey, vntData(i, 3)
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, 2).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)
'★不正理由
'行継続文字の前にSpaceが無い
'行継続文字を無くして1行にするか、Spaceを入れる
vntKey = vntData(i, 1) _
& vbTab & vntData(i, 2)
'Keyが有ったら結果用配列に代入
If .Exists(vntKey) Then
strResult(i, 1) = .Item(vntKey)
End If
Next i
End With
'結果を出力
With rngResult
.Offset(1, 2).Resize(lngRows).Value = strResult
End With
strProm = "処理が完了しました"
Wayout:
Set dicIndex = Nothing
Set rngResult = Nothing
Beep
MsgBox strProm
End Sub
|
|
Hirofumi
- 05/6/12(日) 7:39 -
