| |
bookA.xlsの元データ一覧の有るシート、bookB.xlsの管理番号一覧の有るシート
共に列見出しが有る物とします
bookA.xlsの元データ一覧の有るシートは、"Sheet1"
bookB.xlsの管理番号一覧の有るシートは、"Sheet1"
とします
マクロはどちらのBookに記述しても動くと思います
マクロの実行は、bookA.xls、bookB.xls共に開いて状態で行います
Option Explicit
Public Sub Extraction()
'抽出列数
Const clngCoiumns As Long = 77
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim rngScope As Range
Dim rngResut As Range
Dim rngCriteria As Range
Dim strProm As String
Application.ScreenUpdating = False
'元データ一覧の有るBookのListの有るシートの先頭セル位置
'（見だし「管理番号」の位置）
Set rngList = Workbooks("bookA.xls").Worksheets("Sheet1").Cells(1, "A")
With rngList
'元データの行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "元データのデータが有りません"
GoTo Wayout
End If
'リスト範囲を取得
Set rngScope = .Resize(lngRows + 1, clngCoiumns)
'元データ一覧の有るBookに結果を出力する場合
'結果を出力するシートを追加し、書き込むセル位置を指定
Set rngResut = .Parent.Parent.Worksheets.Add.Cells(1, "A")
'リスト範囲から列見出しをコピー
rngList.Resize(, clngCoiumns).Copy Destination:=rngResut
'抽出範囲とする
Set rngResut = rngResut.Resize(, clngCoiumns)
End With
'管理番号一覧の有るBook
With Workbooks("bookB.xls")
'管理番号一覧の有るシートの管理番号一覧の先頭セル（列見だしが有る物とする）
With .Worksheets("Sheet1").Cells(1, "A")
'管理番号一覧の行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "管理番号一覧のデータが有りません"
GoTo Wayout
End If
'条件範囲を取得
.Value = rngList.Value
Set rngCriteria = .Resize(lngRows + 1)
End With
'管理番号一覧の有るBookに結果を出力する場合
' '結果を出力するシートを追加し、書き込むセル位置を指定
' Set rngResut = .Worksheets.Add.Cells(1, "A")
' 'リスト範囲から列見出しをコピー
' rngList.Resize(, clngCoiumns).Copy Destination:=rngResut
' '抽出範囲とする
' Set rngResut = rngResut.Resize(, clngCoiumns)
End With
'AdvancedFilterを実行
rngScope.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria, _
CopyToRange:=rngResut, _
Unique:=False
strProm = "処理が完了しました"
Wayout:
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResut = Nothing
Set rngScope = Nothing
Set rngCriteria = Nothing
Beep
MsgBox strProm
End Sub
|
|
Hirofumi
- 05/9/25(日) 19:20 -
