| |
Dictionaryじゃ無いけど、こんなので出来ると思います
D列、B列が、共に昇順で整列済みとします
D列、B列共に列見出しが有る物とします
Option Explicit
Option Compare Text
Public Sub Extraction2()
Dim i As Long
Dim rngList1 As Range
Dim lngEnd1 As Long
Dim vntList1 As Variant
Dim lngRow1 As Long
Dim rngList2 As Range
Dim lngEnd2 As Long
Dim vntList2 As Variant
Dim lngRow2 As Long
Dim lngExtract As Long
Dim vntExtract As Variant
Dim strProm As String
'D列のD1を基準とします（データの上のセル位置）
Set rngList1 = Worksheets("Sheet1").Cells(1, "D")
'B列のB1を基準とする
Set rngList2 = Worksheets("Sheet1").Cells(1, "B")
'基準に就いて
With rngList1
'行数を取得
lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngEnd1 < 0 Then
strProm = "D列にデータが有りません"
GoTo Wayout
End If
'品番列を配列に取得
vntList1 = .Offset(1).Resize(lngEnd1).Value
'結果用配列を確保
ReDim vntExtract(1 To lngEnd1, 1 To 1)
End With
'基準に就いて
With rngList2
'行数を取得
lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngEnd2 < 0 Then
strProm = "B列にデータが有りません"
GoTo Wayout
End If
'品目番号列を配列に取得
vntList2 = .Offset(1).Resize(lngEnd2).Value
End With
'書き込み行を初期値に
lngExtract = 0
'"D列"の比較位置
lngRow1 = 1
'"B列"の比較位置
lngRow2 = 1
'D列若しくは,B列が最終行に達するまで繰り返し
Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
'比較結果に就いて
Select Case vntList1(lngRow1, 1)
Case Is = vntList2(lngRow2, 1) 'Matchiした場合
'両データの比較位置の更新
lngRow1 = lngRow1 + 1
lngRow2 = lngRow2 + 1
Case Is > vntList2(lngRow2, 1) '"B列"固有値の場合
'"B列"の比較位置を更新
lngRow2 = lngRow2 + 1
Case Is < vntList2(lngRow2, 1) '"D列"固有値の場合
'出力位置を更新
lngExtract = lngExtract + 1
'結果配列に代入
vntExtract(lngExtract, 1) = vntList1(lngRow1, 1)
'"D列"の比較位置を更新
lngRow1 = lngRow1 + 1
End Select
Loop
'残った"D列"の固有値を出力
For i = lngRow1 To lngEnd1
'出力位置を更新
lngExtract = lngExtract + 1
'結果配列に代入
vntExtract(lngExtract, 1) = vntList1(i, 1)
Next i
Application.ScreenUpdating = False
'抽出データを書きこむ位置を指定
With Worksheets("Sheet1").Cells(1, "F")
.Offset(1).Resize(lngExtract).Value = vntExtract
End With
strProm = "処理が完了しました"
Wayout:
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 08/12/2(火) 21:37 -
