Excel VBA質問箱 IV

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

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


52445 / 76732 ←次へ | 前へ→

【29125】Re:共通するデータの抽出
回答  Hirofumi  - 05/9/25(日) 19:20 -

引用なし
パスワード
   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
0 hits

【29074】共通するデータの抽出 piro 05/9/23(金) 8:20 質問
【29076】Re:共通するデータの抽出 ponpon 05/9/23(金) 8:33 発言
【29118】Re:共通するデータの抽出 piro 05/9/25(日) 13:17 質問
【29125】Re:共通するデータの抽出 Hirofumi 05/9/25(日) 19:20 回答
【29225】Re:共通するデータの抽出 piro 05/9/27(火) 23:56 お礼
【29080】Re:共通するデータの抽出 だるま 05/9/23(金) 10:36 回答
【29120】Re:共通するデータの抽出 piro 05/9/25(日) 13:57 お礼

52445 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free