Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

54951 / 76732

←次へ　｜　前へ→


	【26564】Re:一致したデータの抽出

Hirofumi - 05/7/10(日) 14:42 -


	引用なし

	パスワード

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

1 hits

▼

【26563】一致したデータの抽出 懐園剣 05/7/10(日) 12:01