【Excel】 名簿から抽出したい。

質問

こんにちは

sheet1に住所録があります。

sheet1
名前　　　　住所
アイウエオ　東京都...
カキクケコ　大阪府...
サシスセソ　愛知県...
・ ・
・ ・
・ ・
・ ・

sheet2に名前と日付のリストがあります。

sheet2
名前　　　　日付
アイウエオ　10/2
サシスセソ　10/3
マミムメモ　10/4
カキクケコ 10/2
ラリルレロ 10/1
・ ・
・ ・

sheet3にはsheet2の日付が今日の人のみの住所録を
表示したいのですが、sheet3の式はどのようになるでしょうか。

sheet3
名前　　　　住所
アイウエオ　東京都...
カキクケコ　大阪府...

宜しくお願いいたします。

回答No.1

KenKen_SP · ベストアンサー

こんにちは。KenKen_SP です。

計算式では無理では、、、

ゴリゴリロジックで VBA コードを書いてみました。Sheet3 をアクティブ
にすると自動でデータの抽出を行います。念のため「更新許可」を尋ねる
仕組みにしておきました。

ただ、小規模データの場合は問題ないと思いますが、大規模になると処理
スピードは遅いですね。サンプルデータ1万件で動作確認を行いましたが、
転記処理よりも今日の日付と該当するデータを探す処理（Findメソッド）
でえらく時間がかかります。

注意事項として、Sheet3 の名前は変更しても差し支えありませんが、
Sheet1 および Sheet2 の名前を変更した場合、コードの修正が必要です。

【手順】
1.　シート選択タブ上でSheet3 を選択し、右クリック[コードの表示]
2.　Visual Basic Editor（以下VBE）が起動
3.　VBE 上に以下のコードをコピー＆ペースト
4.　VBE 閉じる
5.　一度他のシートをアクティブにし、再度 Sheet3 をアクティブにして
　　コードが実行されることを確認

'以下終わりまでコード

Option Explicit

Private Sub Worksheet_Activate()

　　Const cstBufSize As Long = 500

　　Dim SH　　 As Worksheet
　　Dim rngDat As Range
　　Dim rngCel As Range
　　Dim rngFnd As Range
　　Dim Buf()　As String
　　Dim i　　　As Long
　　Dim j　　　As Long
　　Dim lngR　 As Long

　　If MsgBox(Format$(Date, "yyyy/mm/dd") & " のデータで更新しますか？", _
　　　　vbOKCancel Or vbDefaultButton2 Or vbInformation) = vbCancel Then
　　　　Exit Sub
　　End If

　　'初期化
　　Application.ScreenUpdating = False
　　Me.Cells.Clear
　　lngR = 2
　　ReDim Buf(cstBufSize)

　　On Error GoTo Terminate

　　'Sheet2 から今日の日付データをもつ行の名前を抽出
　　Set SH = ThisWorkbook.Sheets("Sheet2")
　　Set rngDat = Intersect(SH.UsedRange, SH.Columns(2))
　　For Each rngCel In rngDat
　　　　With rngCel
　　　　　　If Not IsEmpty(.Value) Or _
　　　　　　　 Not IsDate(.Value) Then
　　　　　　　　If .Value = Date Then
　　　　　　　　　　Buf(i) = .Offset(0, -1).Value
　　　　　　　　　　i = i + 1: j = j + 1
　　　　　　　　　　If j = cstBufSize Then
　　　　　　　　　　　　ReDim Preserve Buf(i + cstBufSize)
　　　　　　　　　　　　j = 0
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　End With
　　Next rngCel
　　ReDim Preserve Buf(i - 1)

　　'Sheet1 から抽出した氏名の行を Sheet3 へコピー
　　Set SH = ThisWorkbook.Sheets("Sheet1")
　　Set rngDat = Intersect(SH.UsedRange, SH.Columns(1))
　　SH.Rows(1).Copy Destination:=Me.Rows(1) '見出しコピー
　　For i = 0 To UBound(Buf)
　　　　If Buf(i) <> "" Then
　　　　　　Set rngFnd = rngDat.Find( _
　　　　　　　　What:=Buf(i), _
　　　　　　　　LookIn:=xlValues, _
　　　　　　　　LookAt:=xlWhole)
　　　　　　If Not rngFnd Is Nothing Then
　　　　　　　　rngFnd.EntireRow.Copy Destination:=Me.Rows(lngR)
　　　　　　Else
　　　　　　　　Me.Cells(lngR, 1).Value = Buf(i)
　　　　　　　　Me.Cells(lngR, 2).Value = "No Data"
　　　　　　End If
　　　　　　lngR = lngR + 1
　　　　　　Set rngFnd = Nothing
　　　　End If
　　Next i
　　Erase Buf

Terminate:
　　Application.ScreenUpdating = True
　　If lngR = 2 Then
　　　　MsgBox "該当データはありません", vbInformation
　　End If
　　Set rngDat = Nothing
　　Set rngCel = Nothing
　　Dim SH = Nothing

End Sub