Excel VBA質問箱 IV

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

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


9581 / 13644 ツリー ←次へ | 前へ→

【26563】一致したデータの抽出 懐園剣 05/7/10(日) 12:01 質問[未読]
【26564】Re:一致したデータの抽出 Hirofumi 05/7/10(日) 14:42 回答[未読]
【26565】Re:一致したデータの抽出 懐園剣 05/7/10(日) 15:31 質問[未読]
【26566】Re:一致したデータの抽出 Hirofumi 05/7/10(日) 16:09 回答[未読]
【26568】Re:一致したデータの抽出 懐園剣 05/7/10(日) 16:34 お礼[未読]

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

引用なし
パスワード
   教えてください。
ちょっと前に似たような質問がありますが、
私の場合は、一致したデータを抽出したいのですがどうしたらよいのでしょうか?
(初心者なもので、自分で修正を加えてみたのですが、うまくいきません。)

内容は下記のとおりです。

sheet1:IDのみ
  A
1  ID
2  01
3  02
4  04

sheet2:ID、氏名、年齢
  A   B   C
1  ID  氏名 年齢
2  01  太郎 10
3  02  花子 11
4  03  次郎  9

sheet3:IDが一致したものだけ、sheet2のデータをsheet3に抽出する。
  A   B   C
1  ID  氏名 年齢
2  01  太郎 10
3  02  花子 11

どうぞよろしくお願いします。

【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

【26565】Re:一致したデータの抽出
質問  懐園剣  - 05/7/10(日) 15:31 -

引用なし
パスワード
   ”Hirofumiさん”ありがとうございます。
大変ためになりました。

”Hirofumiさん”もうひとつ質問してもよろしいですか?
sheet2で項目を増やしたい場合は、どこを修正すればよいのでしょうか?

重ね重ねお願いします。

【26566】Re:一致したデータの抽出
回答  Hirofumi  - 05/7/10(日) 16:09 -

引用なし
パスワード
   >sheet2で項目を増やしたい場合は、どこを修正すればよいのでしょうか?

転記する列が、今3列の所を増やしたい?と言う事なら
以下の部分だけを修正して下さい

例えば、3列の転記を5列にしたい場合

  'データの列数
  Const clngCols As Long = 3



  'データの列数
  Const clngCols As Long = 5

とします

【26568】Re:一致したデータの抽出
お礼  懐園剣  - 05/7/10(日) 16:34 -

引用なし
パスワード
   ”Hirofumiさん”ありがとうございます。
よく読めばわかることでした。
お手数をかけてすいません。

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