| |
Sheet1、Sheet2共に、A列(ID)昇順で整列済みとします
Option Explicit
Option Compare Text
Public Sub Extraction()
'データの列数
Const clngCols As Long = 3
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 rngResult As Range
Dim lngWrite As Long
Dim strProm As String
Application.ScreenUpdating = False
'Sheet1のA1を基準とします（Listの左上隅）
Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
With rngList1
'行数を取得
lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngEnd1 <= 0 Then
strProm = .Parent.Name & "のデータが有りません"
GoTo Wayout
End If
'番号列を配列に取得
vntList1 = .Offset(1).Resize(lngEnd1).Value
End With
'Sheet2のA1を基準とする
Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
With rngList2
'行数を取得
lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngEnd2 <= 0 Then
strProm = .Parent.Name & "のデータが有りません"
GoTo Wayout
End If
'番号番号列を配列に取得
vntList2 = .Offset(1).Resize(lngEnd2).Value
End With
'出力するシートの基準位置を設定
Set rngResult = Worksheets("Sheet3").Cells(1, "A")
'列見出しの出力
rngList2.Resize(, clngCols).Copy Destination:=rngResult
'出力行の初期化
lngWrite = 1
'Sheet1の比較位置
lngRow1 = 1
'Sheet2の比較位置
lngRow2 = 1
'Sheet1若しくは,Sheet2が最終行に達するまで繰り返し
Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
'比較結果に就いて
Select Case vntList1(lngRow1, 1)
Case Is = vntList2(lngRow2, 1) 'Matchiした場合
With rngList2
.Offset(lngRow2).Resize(, clngCols).Copy _
Destination:=rngResult.Offset(lngWrite)
End With
lngWrite = lngWrite + 1
'両Sheetの比較位置の更新
lngRow1 = lngRow1 + 1
lngRow2 = lngRow2 + 1
Case Is > vntList2(lngRow2, 1) 'Sheet2固有行の場合
'Sheet2の比較位置を更新
lngRow2 = lngRow2 + 1
Case Is < vntList2(lngRow2, 1) 'Sheet1固有行の場合
'Sheet1の比較位置を更新
lngRow1 = lngRow1 + 1
End Select
Loop
strProm = "処理が完了しました"
Wayout:
Set rngList1 = Nothing
Set rngList2 = Nothing
Set rngResult = Nothing
Application.ScreenUpdating = True
Beep
MsgBox strProm
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
