|
Sheet1が以下の様
A B
1 100 鉛筆
2 200 メモ
3 250 ノート
Sheet2が以下の様
A B
1 50 みかん
2 100 りんご
3 150 なし
4 250 メロン
基本的に だるま さん と同じロジックのコードです
Option Explicit
Public Sub Extraction()
'データの列数
Const clngColumns As Long = 2
Dim i As Long
Dim lngEnd1 As Long
Dim vntList1 As Variant
Dim lngRow1 As Long
Dim lngEnd2 As Long
Dim vntList2 As Variant
Dim lngRow2 As Long
Dim vntResult As Variant
Dim lngWrite As Long
Dim strProm As String
'Sheet1のA1を基準とします(Listの左上隅)
With Worksheets("Sheet1").Cells(1, "A")
'行数を取得
lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
If lngEnd1 <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'A、B列を配列に取得
vntList1 = .Resize(lngEnd1, clngColumns).Value
End With
'Sheet2のA1を基準とする
With Worksheets("Sheet2").Cells(1, "A")
'行数を取得
lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
If lngEnd1 <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'A、B列を配列に取得
vntList2 = .Resize(lngEnd2, clngColumns).Value
End With
'結果出力用配列を確保
ReDim vntResult(1 To lngEnd1 + lngEnd2, 1 To clngColumns * 2)
'書き込み行を初期値に(Offse値)
lngWrite = 0
'Sheet1のA列の比較位置
lngRow1 = 1
'Sheet2のA列の比較位置
lngRow2 = 1
'Sheet1のA列若しくは,Sheet2のA列が最終行に達するまで繰り返し
Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
'出力位置を更新
lngWrite = lngWrite + 1
'比較結果に就いて
Select Case vntList1(lngRow1, 1)
Case Is = vntList2(lngRow2, 1) 'Matchiした場合
'データを配列に代入
vntResult(lngWrite, 1) = vntList1(lngRow1, 1)
vntResult(lngWrite, 2) = vntList1(lngRow1, 2)
vntResult(lngWrite, 3) = vntList2(lngRow2, 1)
vntResult(lngWrite, 4) = vntList2(lngRow2, 2)
'両データの比較位置の更新
lngRow1 = lngRow1 + 1
lngRow2 = lngRow2 + 1
Case Is > vntList2(lngRow2, 1) 'Sheet2のA列固有行の場合
'Sheet2のデータを配列に代入
vntResult(lngWrite, 3) = vntList2(lngRow2, 1)
vntResult(lngWrite, 4) = vntList2(lngRow2, 2)
'Sheet2のA列の比較位置を更新
lngRow2 = lngRow2 + 1
Case Is < vntList2(lngRow2, 1) 'Sheet1のA列固有行の場合
'Sheet1のデータを配列に代入
vntResult(lngWrite, 1) = vntList1(lngRow1, 1)
vntResult(lngWrite, 2) = vntList1(lngRow1, 2)
'Sheet1のA列の比較位置を更新
lngRow1 = lngRow1 + 1
End Select
Loop
'残ったSheet1のA列の固有値を出力
For i = lngRow1 To lngEnd1
'出力位置を更新
lngWrite = lngWrite + 1
'データを配列に代入
vntResult(lngWrite, 1) = vntList1(i, 1)
vntResult(lngWrite, 2) = vntList1(i, 2)
Next i
'残ったSheet2のA列の固有値を出力
For i = lngRow2 To lngEnd2
'出力位置を更新
lngWrite = lngWrite + 1
'データを配列に代入
vntResult(lngWrite, 3) = vntList2(i, 1)
vntResult(lngWrite, 4) = vntList2(i, 2)
Next i
Application.ScreenUpdating = False
'抽出データを書きこむ位置を指定し結果配列を出力
With Worksheets("Sheet1").Cells(1, "A")
.Resize(lngWrite, clngColumns * 2).Value = vntResult
End With
Application.ScreenUpdating = True
strProm = "処理が完了しました"
Wayout:
MsgBox strProm, vbInformation
End Sub
|
|