Excelのデータから一部のデータを別シートに抽出するマクロを組みたい

質問

毎日更新されるExcelのデータから、指定した日のデータのみを別シートで抽出するマクロを組みたいのです。
【毎日更新して追加されるデータ】
列　　　A　　　　　B　　　　C　　　　D
　　入会日　　　会員番号　会員名　会員種別
　　2009/7/21　　12345　　花子　　　　5
　　2009/7/21　　12345　　次郎　　　　7　　
　　2009/7/22　　12347　　太郎　　　　4

上記のように毎日追加される全体のデータから、指定した入会日のデータのみを別シートのテンプレートにもってきたいのです。
【テンプレート】は添付データのようなフォーマットです。
入会日を変えることにより、該当するデータをその都度テンプレートに反映させるようにするマクロはどのようにしたらよいでしょうか？
ちなみに、全体のデータとテンプレートのシートは同じファイルです。
どうぞよろしくお願いいたします。

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.8

kmetu

私はその都度マクロを実行しデータを追加していくのだと思ってましたが
もしかして日付を変更しただけでデータが変更(現状のデータは消される)
されるということでしょうか。

としたら
Summary SheetのVBEで以下のコードを

Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Integer, LastRow As Integer
Dim c As Object
Dim firstAddress As String

If Target.Address = "$B$2" Then

i = 0

If Range("D5") <> "" Then
Range("B5:" & Range("D65536").End(xlUp).Address).Clear
End If

With Worksheets("Log Sheet").Range("A2:" & Range("A65536").End(xlUp).Address)
Set c = .Find(ActiveSheet.Range("B2").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ActiveSheet.Range("B5").Offset(i, 0) = c.Offset(0, 1).Value
ActiveSheet.Range("C5").Offset(i, 0) = c.Offset(0, 2).Value
ActiveSheet.Range("D5").Offset(i, 0) = c.Offset(0, 3).Value
i = i + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

End If

End Sub

回答No.7

kmetu

画像がないのでシート名だけを参考にします。
多分セルの指定が違うんだと思いますのでその部分の説明です。

LastRow = Range("B65536").End(xlUp).Row + 1
このB65536のBはSummary Sheetの会員番号を入れる列を指定してください。

With Worksheets("Log Sheet").Range("A2:" & Range("A65536").End(xlUp).Address)

Range("A2:" & Range("A65536").の
AはLog Sheetの入会日の列を指定してください。
A2は入会日の一番上のセル番号を指定してください。

お礼

kmetuさん、

本当に何度もご手数をおかけしてすみません。
行き違いになってしまい、再度同じ質問を「Excelのデータから一部のデータを別シートに抽出するマクロを組みたい2」で投稿してしまいました。どうしてもマクロが動かないのはなぜでしょうか？
下記をチェックしていただけないでしょうか？
本当にすみません。
Sub test()

Dim i As Integer, LastRow As Integer
Dim c As Object
Dim firstAddress As String

i = 0
LastRow = Range("B65536").End(xlUp).Row + 1

With Worksheets("Log Sheet").Range("C2:" & Range("C65536").End(xlUp).Address)
Set c = .Find(ActiveSheet.Range("F1").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ActiveSheet.Range("B" & LastRow).Offset(i, 0) = c.Offset(0, 1).Value
ActiveSheet.Range("C" & LastRow).Offset(i, 0) = c.Offset(0, 2).Value
ActiveSheet.Range("F" & LastRow).Offset(i, 0) = c.Offset(0, 6).Value
i = i + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

回答No.6

kmetu

LastRow = Range("B65536").End(xlUp).Row + 1
は
Range("B65536").End(xlUp).Row
でB列のデータの入力されている最後の行を
最終行(エクセル2003までを想定)から検索しています。
最初は会員番号と入力されているセルが最後の行になりますから
4が結果として返ります。
それに1を足してLastRowに代入し
日付を検索して見つかった一番最初の動作は
ActiveSheet.Range("B" & LastRow).Offset(i, 0) = c.Offset(0, 1).Value
会員番号の次のセルに毎日更新して追加されるシートの該当セルのデータを入れています。

画像で示されているシートの入会日B2に2009/7/21を入力してから
そのシートを表示した状態でマクロを実行してみてください。
【毎日更新して追加されるデータ】が質問と同じ場合
示されている画像のような結果になると思います。

補足

kmetuさん、

何度も質問して申し訳ありません。
しかしなぜかマクロがどうしても動いてくれません。
そこで、質問の時は例としてデータの配列をしてたものを、実際に作成しているデータの配列を画像で示しますので、どうかよろしくお願いいたします。
上の画像のシート名：Log Sheet
下の画像のシート名：Summary Sheet

回答No.5

kmetu

> Dim c As Object
>
> →ここのcとは何を意味しているのでしょうか？

Findで見つかったセルの情報をオブジェクトとしてcという変数に入れたいので
cはオブジェクト変数ですと宣言しているところです。

> i = 0
>
> →ここのiとは何を意味しているのでしょうか？

ActiveSheet.Range("D" & LastRow).Offset(i, 0)
i = i + 1
で利用しているのですが、セルの番地をオフセットで示し(初期値を0にしてます)
一行ずつ下にずらしていくための行の指定をiという変数にしています。

> →”Sheet1”とは、参照先のシート名を入れればよいのでしょうか？

そうです。毎日更新して追加されるデータのシートです。

> アクティブにした状態とは、テンプレートのシートを右クリックしてコードの表示をして上記のマクロを入れればよいということでしょうか？

マクロはVBEを開いてどこにおいてもいいです、たとえばThisWorkbookでも。
マクロの実行をするときに「テンプレート」のシートの
どこかのセルを選択した状態にしておいてくださいということです。

開いている(アクティブな)シートのB2と同じ日付のデータを
毎日更新して追加されるデータのシートのA列からさがして
見つかったデータをアクティブなシートのB列の最後のデータが入っている
次のセルから順に(CDの同列セルにも必要なデータを)
コピーしていくという仕様になっています。

補足

kmetuさん、

早速ご回答をいただきまして、ありがとうございます。
しかし残念ながらうまくマクロが動いてくれません。
何が問題なのかよく分かっていません。

そこで確認なのですが、下記のRange("B65536")は何をあらわしているのでしょうか？

i = 0
LastRow = Range("B65536").End(xlUp).Row + 1

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

回答No.4

tom04

こんばんは！
VBAではないので希望とは外れるかもしれません。
参考にならなかったら無視してくださいね。

関数での方法になります。

↓の画像のようにSheet1のデータをSheet2以降に自動で反映させるようにしています。

質問内容をみると会員番号が重複していますので
Sheet2に、重複がないと思われる会員名を表示させ
そのデータに基づき会員番号と会員種別を表示させるようにしています。

まず、Sheet2のC3セルに
=IF(COUNTIF(Sheet1!$A$2:$A$100,$B$1)>=ROW(A1),INDEX(Sheet1!$C$2:$C$100,SMALL(IF(Sheet1!$A$2:$A$100=Sheet2!$B$1,ROW(Sheet1!$A$1:$A$99)),ROW(A1))),"")

C3セルに関しては配列数式になりますので
上の数式をC3セルにコピー＆ペーストして（この段階ではエラーになるかもしれません）
F2キーを押すか、数式バー内で一度クリックし、編集可能にした後に
Shift＋Ctrl＋Enterキーを押してください。
数式の前後に　｛　｝記号が入り配列数式になります。

次にB3セルに
=IF(C3="","",INDEX(Sheet1!$B$2:$B$6,MATCH(C3,Sheet1!$C$2:$C$6,0)))

D3セルに
=IF(C3="","",INDEX(Sheet1!$D$2:$D$6,MATCH(C3,Sheet1!$C$2:$C$6,0)))

最後にB3～D3セルを範囲指定し、オートフィルで下へコピーすると
↓のような表になります。

尚、Sheet1のデータは　A100　までのデータと仮定しての数式ですので
データ数が多い場合はアレンジしてください。

日付を入れていないSheet2をそのまま別Sheetにあらかじめコピー＆ペーストしておいて

日付だけ入力してもSheet1のデータを入力するたびに、反映されるはずです。

以上、参考になれば幸いですが、
まったく的外れの可能性もありますので
その場合はごめんなさいね。m(__)m

回答No.3

kmetu

Sub test()

Dim i As Integer, LastRow As Integer
Dim c As Object
Dim firstAddress As String

i = 0
LastRow = Range("B65536").End(xlUp).Row + 1

With Worksheets("Sheet1").Range("A2:" & Range("A65536").End(xlUp).Address)
Set c = .Find(ActiveSheet.Range("B2").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ActiveSheet.Range("B" & LastRow).Offset(i, 0) = c.Offset(0, 1).Value
ActiveSheet.Range("C" & LastRow).Offset(i, 0) = c.Offset(0, 2).Value
ActiveSheet.Range("D" & LastRow).Offset(i, 0) = c.Offset(0, 3).Value
i = i + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

End Sub

でいかがでしょう。
テンプレートのシートをアクティブにした状態で実行してください。

補足

kmetuさん、

早速ありがとうございます。
いくつか質問がありますので回答をお願いします。

Sub test()

Dim i As Integer, LastRow As Integer
Dim c As Object

→ここのcとは何を意味しているのでしょうか？

Dim firstAddress As String

i = 0

→ここのiとは何を意味しているのでしょうか？

LastRow = Range("B65536").End(xlUp).Row + 1

With Worksheets("Sheet1").Range("A2:" & Range("A65536").End(xlUp).Address)

→”Sheet1”とは、参照先のシート名を入れればよいのでしょうか？
Set c = .Find(ActiveSheet.Range("B2").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ActiveSheet.Range("B" & LastRow).Offset(i, 0) = c.Offset(0, 1).Value
ActiveSheet.Range("C" & LastRow).Offset(i, 0) = c.Offset(0, 2).Value
ActiveSheet.Range("D" & LastRow).Offset(i, 0) = c.Offset(0, 3).Value
i = i + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

End Sub

でいかがでしょう。
テンプレートのシートをアクティブにした状態で実行してください。

→アクティブにした状態とは、テンプレートのシートを右クリックしてコードの表示をして上記のマクロを入れればよいということでしょうか？

初心者なので、基本的な質問をして申し訳ないのですがお答えいただけないでしょうか？
どうぞよろしくお願いいたします。

回答No.2

cistronezk

とりあえずマクロを記録しましょう。それでほどんと出来る作業です。

まず、データシートにオートフィルタをかけておきます。それから以下の手順をマクロで記録します。
（１）データシートをアクティブにし、入会日でフィルタをかけます（例：2009/7/21）
（２）セルB2を選び、Ctrl+Shift+Endでフィルタされた全データを選択します
（３）コピーします
（４）テンプレートシートをアクティブにし、セルB5を選択します
（５）「形式を指定して貼り付け」で値を選択して張り付けます

これによって、
Selection.AutoFilter Field:=1, Criteria1:="2009/7/21"
というコマンドが記録されます。
この「Criteria1:="2009/7/21"」の部分を「Criteria1:=Worksheets("てんぷれーとしーと").Range("B2").Value」
に変更すればOKです。

これだけでは、２度目以降に実行したときに、前のデータが残ってしまうので、それを消すマクロが必要です。これも記録します。
（１）テンプレートシートをアクティブにし、セルB5を選択します
（２）セルB5を選び、Ctrl+Shift+Endでフィルタされた全データを選択します
（３）削除します
このマクロは、手直しせずにそのままつかえます。このマクロを上のマクロの前に実行します。

以上です。

回答No.1

mshr1962

一例です。

Sub Set_Macro()
Dim RG As Range
Dim CN As Integer

Sheets("集計表").Select
If IsDate(Range("B2")) Then
Range("B5:D60000").ClearContents

For Each RG In Sheets("元の表").Range("A2:A60000")

Select Case RG
Case Range("B2")
Range("B5").Offset(CN, 0) = RG.Offset(0, 1)
Range("B5").Offset(CN, 1) = RG.Offset(0, 2)
Range("B5").Offset(CN, 2) = RG.Offset(0, 3)
CN = CN + 1

Case Null
Exit For

End Select
Next RG

Else
MsgBox "日付を入力してください", vbOK, "データ抽出"
End If

End Sub