| |
▼Hirofumi さん：
Sheet名を入れ替えたりと何度かしていると、下記のコードで出来るようになりました。
Dim strProm As String
'Sheet 2のList先頭セルを指定（列見出しの左上隅）←Dコードの入ったSheet’
With Worksheets("Sheet 2").Cells(1, "A")
'Sheet 1のList先頭セルを指定（列見出しの左上隅）←Dコードを入れたいSheet’
Set rngResult = Worksheets("Sheet 1").Cells(1, "A")
初心者の私には何が原因だったのか解読できていないのですが…
こんなにも処理速度の早いコードを作っていただきありがとうございました。
重複確認プログラムも使わせていただきます。
わがままついでにもうひとつ質問なんですが、
３つのコードを２つに減らしたり４つに増やしたりした場合は、
下記の4.3.←☆の部分を変更すればいいのでしょうか？
'データを配列に取得
vntData = .Offset(1).Resize(lngRows, 4.).Value
End With
'Dictionaryオブジェクトのインスタンスを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'Indexを作成
With dicIndex
'データ全てに繰り返し
For i = 1 To lngRows
'世話組織コード、組織コード、事業所コードをKeyとする
vntKey = vntData(i, 1) & vbTab _
& vntData(i, 2) _
& vbTab & vntData(i, 3) ←☆
'もしKeyが重複する場合
If .Exists(vntKey) Then
strProm = "Keyが重複しています"
GoTo Wayout
Else
'Keyと配便コードをIndexに登録
.Add vntKey, vntData(i, 4.)
End If
Next i
End With
'配便コード付のList先頭セルを指定（列見出しの左上隅）
Set rngResult = Worksheets("配便コード付").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)
'世話組織・組織・事業所コード（配便コード順）0507の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
|
|
Lee
- 05/6/11(土) 0:53 -
