Excel VBA質問箱 IV

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

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


9125 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

【29074】共通するデータの抽出
質問  piro  - 05/9/23(金) 8:20 -

引用なし
パスワード
   はじめまして。

あるデータ一覧から別のデータ一覧で指定された
共通する数値データを抽出したいのですが、
方法がわからず困っています。

指定された2つのセル範囲のデータを調べ、
共通データを抽出、または色をつける、
というようなことを考えていますが、
良い方法を教えていただけませんでしょうか?
それぞれのセル範囲のセル数は異なっています。

以上、よろしくお願いいたします。

【29076】Re:共通するデータの抽出
発言  ponpon  - 05/9/23(金) 8:33 -

引用なし
パスワード
   おはようございます。

これだけの説明では、よくわかりません。

シートのレイアウトやデータの入力状況
望む結果のシートの状態などを詳しく説明し他方がレスがつきやすいと思います。

【29080】Re:共通するデータの抽出
回答  だるま WEB  - 05/9/23(金) 10:36 -

引用なし
パスワード
   こんにちは

とりあえずこんな感じでいかがでしょうか。^d^

Sub test()
  Dim rngA As Range
  Dim rngB As Range
  Dim Dic As Object
  Dim myCell As Range
  
  Set rngA = ActiveSheet.UsedRange.Columns("A:A")
  Set rngB = ActiveSheet.UsedRange.Columns("B:B")
  
  Set Dic = CreateObject("Scripting.Dictionary")
  
  For Each myCell In rngA.Cells
    Dic.Item(CStr(myCell.Value)) = Empty
  Next
  
  For Each myCell In rngB.Cells
    With myCell
      If Dic.Exists(CStr(.Value)) Then
        .Interior.ColorIndex = 3
      End If
    End With
  Next
  
  Set myCell = Nothing
  Set Dic = Nothing
  Set rngB = Nothing
  Set rngA = Nothing
End Sub

範囲指定はどうしたいのか分からなかったので固定にしてあります。

なお、もっと簡単に実行したいということでしたらこんな出来合いのソフトもあります。
(ただし、列どうしの比較のみですが)

秒速!ダブリ出し
http://www.vector.co.jp/soft/win95/business/se363400.html

【29118】Re:共通するデータの抽出
質問  piro  - 05/9/25(日) 13:17 -

引用なし
パスワード
   ponpon様、ご指摘ありがとうございました。
質問の仕方もままならずお恥ずかしい限りです。。。
その後、だるま様に教えて頂いたソフトで近い事ができそうなのですが、
勉強のために再度質問させて頂きます。


■目的

あるデータ一覧から別のデータ一覧で指定された共通するデータを抽出する。

■シートのレイアウトと入力状況

【bookA】←元データ一覧(同一管理番号が複数連続する行もあります)

  A列     B列    C列    D列   E列   F列 ・・・・BY列
管理番号  氏名   住所   電番   担当  項目1・・・項目76
12345678  ○○   ○○   ○○   ○○   A ・・・・0
12345712  ○○   ○○   ○○   ○○   A ・・・・0
12345712  ○○   ○○   ○○   ○○   B ・・・・0
12345712  ○○   ○○   ○○   ○○   C ・・・・0
12339825  ○○   ○○   ○○   ○○   A ・・・・0
12339825  ○○   ○○   ○○   ○○   B ・・・・0
12400114  ○○   ○○   ○○   ○○   A ・・・・0
   :
行数不定(50行〜2万行程度)

【bookB】←bookAから抽出したい管理番号一覧
 A列
12345712   
12400114
   :
行数不定(10行から500行程度)

・bookAに直接、bookBのA列を挿入して作業しても問題ありません。

■最終的に望むシートの状態

抽出したい管理番号行(同一管理番号がある場合は全て含む)
のみがBY列まで表示されている状態。
…がベストですが、
まずは bookA と bookB に共通して存在する管理番号が bookA 上で
何らかの方法でわかればありがたいです。

bookA にbookB のA列を挿入し、共通データをハイライトさせてから
フラグを立てて抽出する方法も考えています。

以上、良い方法をご存知の方がいらっしゃいましたらご教授お願い致します。

【29120】Re:共通するデータの抽出
お礼  piro  - 05/9/25(日) 13:57 -

引用なし
パスワード
   だるま様

こんにちは。レスありがとうございました。

20行程度で作った疑似データで試したところ、
大変良い具合にハイライトされました!どうもありがとうございます。
内容についてはこれからじっくり勉強させて頂きます。

最終的な作業目的は共通するデータ行のみの表示なのですが、
行数が少ない場合には、こちらの記述を使わせて頂き、
ハイライトされた行にフラグを付けフィルタリング、
という事で充分に対応できます。
本当にありがとうございました!

また便利そうなソフトをご紹介頂きありがとうございます。
こちらのソフトを使うまでもなく、
教えて頂いた記述で目的に近い作業ができます^^

【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

【29225】Re:共通するデータの抽出
お礼  piro  - 05/9/27(火) 23:56 -

引用なし
パスワード
   Hirofumi 様

レスありがとうございました。

教えていただいたマクロ、
やっと今日試してみることができました。
そして、まさしく思い描いていたとおりの結果が表示されました!
3000行ほどのデータで実行しましたが、
処理も瞬時に終わり驚きました。
丁寧な説明をつけてくださったおかげで、
初心者の私でも理解しやすいものになっています。

本当にありがとうございました。

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