『（VBA質問）フィルタできる値ごとにシート追加してデータコピー』（VBA勉強中） VBA初心者で勉強中の者です。 書籍やWebで調べてもわからないため、教えていただけますと幸いです。 A列からF列までデータが入った、3000行ほどのデータがあります。（列、行の数は可変します） C列に、日付データが入っていて、日付は5通りほどに絞られます。(日付は毎回異なる値となります） C列でフィルタをかけて、それぞれの日付ごとのデータを抜き出し、 それらを日付ごとにシートを追加した上で、それぞれのシートにデータを張り付けます。 その際に、シート名は「日付」となるようにしたいと思っています。 またできれば、上記のデータを張り付ける（コピーする）際に、C列(抜き出した後は日付データは不要なため）、E-F列などの不要な列を削除した上で、コピーできるとありがたいです。 ご教授いただけると助かります。 よろしくお願いいたします。 ＜ 使用 Excel：Office365、使用 OS：Windows10 ＞ ---- ＞C列でフィルタをかけて、 オートフィルタを使っているなら、なにも考えずに必要な列だけコピペしてみてはどうですか？ また、項目行があるなら、フィルタオプションの利用を考えるとよいかもしれません。 （もこな２） 2021/12/21(火) 12:55 ---- もこな２さん、ありがとうございます。 言葉が足りておらず失礼いたしました。 手動で行うことはできるんですが、上記の作業をマクロで自動化したいと思っています。 また日付データも、都度で可変するデータとなるため、指定値で組む形ではなく、 可変する値を抽出して、それらにてフィルタをかけるような設定となるため、 なかなか思うような形にならないという状況です。 よろしくお願いいたします。 （VBA勉強中） 2021/12/21(火) 14:01 ---- 手動でできているなら、マクロの記録をしてみるのが とっかかりをつくるにはいい方法です どういう回答がお望みなんでしょうか？ 具体的に、解らないところ、うまくいかないところはどんなことですか？ 質問に具体性がないので、なにを回答すればいいのか困ります。 全部まるっと作ってくれというなら、そう書いた方がいいです。 それで勉強になるかどうかはわかりませんが （´・ω・`） 2021/12/21(火) 14:19 ---- こちらも言葉がたりなかったかもしれません。 ■１ ＞上記の作業をマクロで自動化したいと思っています。 それは、タイトルやニックネームから理解しています。 そのうえで、↓を【マクロの記録】でコード化すると必要な命令がわかりますよ。という意味でした。 ＞＞オートフィルタを使っているなら、なにも考えずに必要な列だけコピペしてみてはどうですか？ ■２ ＞また日付データも、都度で可変するデータとなるため、指定値で組む形ではなく、可変する値を抽出 結局オートフィルタの話なのかわかりませんが、オートフィルタの場合であれば、日付を抽出条件にする場合、【文字列】で指定してやる必要があります。 http://officetanaka.net/excel/vba/tips/tips151.htm ＞C列に、日付データが入っていて、日付は5通りほどに絞られます。 また↑ですから、C列のデータから【重複しない】リストを得れば、必要な日付を得ることができるということになります。 http://officetanaka.net/excel/vba/tips/tips80.htm ■３ ということを踏まえると、オートフィルタであれば (1)C列から重複しないリストを作る (2)(1)のリストに沿って、抽出を実行して、シートを新規追加して、必要な列のみコピーして追加したシートに貼り付ける (3)(2)をリスト分繰り返す という処理を考えればよいわけです。 ■４ また、フィルタオプションであれば (1)C列から重複しないリストを作る 　(2)(1)のリストに沿って、シートを新規追加して、抽出結果を出力する 　(3)(2)をリスト分繰り返す ですね。 いずれも、マクロの記録で主要な命令は調べられますのでトライしてみては如何でしょうか？ （もこな２） 2021/12/21(火) 14:45 ---- >手動で行うことはできるんですが、上記の作業をマクロで自動化したいと思っています。 >また日付データも、都度で可変するデータとなるため、指定値で組む形ではなく、 >可変する値を抽出して、それらにてフィルタをかけるような設定となるため、 >なかなか思うような形にならないという状況です。 手動で行うときの手順（流れ）を日本語で書き出すところから始めてみてはいかがでしょうか。 前提条件＞ ・すでにブックにデータがある ・同じブック内に日付別のシートを作成する。 作業の大まかな流れ 1）データの一覧から、ユニーク（唯一無二）な日付を抽出する 2）ユニークな日付でシート追加し該当データを転記 極論これをやりたいのだと思います。 ただこれだけでは、だれも作業できません。 事細かな作業手順を説明する必要があります。 個別の作業の流れ ＜ユニークな日付の抽出＞ 0）始まり 1）データのシートを新しいブックにコピー 2）重複データの削除で日付列を選択して、重複削除 3）終わる ＜日付毎の抽出＞ 0）始まり 1）新規ブックを開く(一時的な作業用） 2）重複を削除した日付データごとに繰り返し 3）新規ブックにフィルターオプションの条件欄作成 4）自ブックに新規シートの追加（+名前の変更） 5）新規シートに抽出したいタイトル行を作成 6）フィルターオプションで新規シートに転記 7）3に戻る 8）作業用ブック（2つ）は保存せずに閉じる 9）終わり ざっくりこんな感じかなぁってところを考えるところから、プログラミングは始まってます。 （むしろ作業手順を考えるのがプログラミングで、VBAを使うか他のプログラミング言語を使うかは、 別の話、運動会のプログラムとかプログラムは色んな場面で出てきますよね？それと基本同じ） あとは、作りながらその都度、変更修正追加等していく感じでしょうか。 ご自分で出来ることはチャレンジしてみて、躓いたら躓いたところを質問するようにしましょう。 あと、この手の質問＆回答はネット上に山ほどあります。（ここの過去ログにもあるかと） 参考にしてみては？ （まっつわん） 2021/12/21(火) 19:34 ---- 「抽出 → 抽出したものだけ転記」×日付 が基本なんでしょうけど、 3000行程度なのであれば、 「まるごとコピー → 要らん所を削除」×日付 でもそこそこイイ動きするんじゃないかと思います。 コード書く手間もあんまり変わんないでしょうし、 元の表の体裁をなるべく維持したい場合なんかは割と効率的ですよ。 （白茶） 2021/12/21(火) 20:36 ---- Sub sample() Dim DateListRange As Range Dim UniqueDateList() As Variant, d As Variant Dim sourcews As Worksheet Dim ws As Worksheet, CriteriaSheet As Worksheet Set sourcews = ActiveSheet ' 元データシートの指定 With sourcews Set DateListRange = .Range("C2", .Cells(.Rows.Count, 3).End(xlUp)) End With With WorksheetFunction UniqueDateList = .Sort(.Unique(DateListRange.Value)) End With Set CriteriaSheet = ThisWorkbook.Worksheets.Add CriteriaSheet.Range("A1").Value = sourcews.Range("C1").Value For Each d In UniqueDateList CriteriaSheet.Range("A2").Value = d Set ws = GetSheetByDate(CDate(d)) ws.Cells.Clear With ws ' 書き出す列名の指定 .Cells(1, 1) = sourcews.Cells(1, 3) .Cells(1, 2) = sourcews.Cells(1, 1) .Cells(1, 3) = sourcews.Cells(1, 5) .Cells(1, 4) = sourcews.Cells(1, 7) End With sourcews.Range("C1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=CriteriaSheet.Range("A1:A2"), _ CopyToRange:=ws.Range("A1").CurrentRegion, Unique:=False Next Application.DisplayAlerts = False CriteriaSheet.Delete Application.DisplayAlerts = True End Sub Function GetSheetByDate(targetDate As Date, Optional ByVal dateformat = "yyyymmdd", Optional ByVal wb As Workbook) Dim ws As Worksheet Dim ShName As String If wb Is Nothing Then Set wb = ThisWorkbook ShName = Format(targetDate, dateformat) On Error Resume Next Set ws = wb.Worksheets(ShName) On Error GoTo 0 If ws Is Nothing Then Set ws = wb.Worksheets.Add ws.Name = ShName End If Set GetSheetByDate = ws End Function （´・ω・`） 2021/12/21(火) 21:53 ---- みなさん、コメントありがとうございます。 ※昨日、書き込んだつもりでおりましたが、書き込みができおらず、お礼が遅くなり申し訳ありません。 もこな２さん： 参考URLなどありがとうございます。こちらで勉強させていただきます。 （´・ω・`）さん： コード教えていただきありがとうございます。知識が薄いため内容を把握するまでは至っておりませんが、拝見しながら要素勉強させていただきます。 まっつわんさん： プログラミングの考え方、非常に勉強になります。一足飛びに考えるのではなく、順序立てて考えていくのですね。ありがとうございます。 白茶さん： なるほど、そのような方法もありますね。それであれば、私でもできそうです。視点を変えて考えるというのは大事ですね。 （VBA勉強中） 2021/12/22(水) 09:05 ---- （´・ω・`）さん たびたび申し訳ありません。 頂いたコードを元にして、少しずつ私のデータに合わせて修正を行っています。 以下いただいたコードの部分で、列の範囲指定を行いたいと思っていて、RangeやColumnなど使用しつつ試してみてもデータをうまくコピーできません。 こちらの中で、H-K列などのような範囲で指定をする方法ありますでしょうか？ 教えていただけますと幸いです。 With ws ' 書き出す列名の指定 .Cells(1, 1) = sourcews.Cells(1, 3) .Cells(1, 2) = sourcews.Cells(1, 1) .Cells(1, 3) = sourcews.Cells(1, 5) .Cells(1, 4) = sourcews.Cells(1, 7) 　.Range("E:H") = sourcews.Range("H:K") ←仮にこのように入れても、無視されてしまいます。 End With （VBA勉強中） 2021/12/22(水) 14:59 ---- .Range("E1:H1").Value = sourcews.Range("H1:K1").Value のようにValueプロパティにしてください。 それと、タイトル行(1行目)だけコピーしてください また、その上の .Cells(1, 1) = sourcews.Cells(1, 3) も .Cells(1, 1).Value = sourcews.Cells(1, 3).Value とした方がいいですね （´・ω・`） 2021/12/22(水) 15:17 ---- （´・ω・`）さん ありがとうございます！ 教えていただいた内容で無事改善できました！ 大変助かりました。 （VBA勉強中） 2021/12/22(水) 16:45 ---- 解決したようですが、まぁこういう方法もありますよということで。 興味があれば、手の空いたときに研究してみて下さい。 （既にお伝えの通り、ループ処理以外はマクロの記録でほぼ調べられる範囲かとおもいます） 【元データ】シートのレイアウト __A___ __B__ ___C____ __D__ __E__ __F__ 1 項目1　　　項目2　　　項目3　　　項目4　　　項目5　　　項目6 2 あ　　　 い　　　2021/4/5　　　A　　　 1　　　 123 3 い　　　 ろ　　　2021/7/8　　　B　　　 2　　　 123 4 う　　　 は　　　2022/1/8　　　C　　　 1　　　 123 5 え　　　 に　　　2020/4/5　　　A　　　 2　　　 123 6 お　　　 ほ　　　2021/4/5　　　B　　　 1　　　 123 7 か　　　 へ　　　2021/4/5　　　C　　　 2　　　 123 8 き　　　 と　　　2021/7/8　　　A　　　 1　　　 123 9 く　　　 ち　　　2022/1/8　　　B　　　 2　　　 123 10 け　　　 り　　　2022/1/8　　　C　　　 1　　　 123 Sub 研究用() Stop 'ブレークポイントの代わり Dim 行 As Long, 日付 As Date Worksheets.Add.Name = "作業用" '★シートを追加する命令はマクロの記録で調べられます（ここではついでに名前を変えています） With Worksheets("元データ") .AutoFilterMode = False .Range("C:C").Copy Worksheets("作業用").Range("A1") '★コピーする命令自体はマクロの記録で調べられます Worksheets("作業用").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes '★重複の削除をする命令はマクロの記録で調べられます .Range("A:F").AutoFilter '★オートフィルタを設定する命令自体はマクロの記録で調べられます For 行 = 2 To Worksheets("作業用").Cells(Rows.Count, "A").End(xlUp).Row 日付 = Worksheets("作業用").Cells(行, "A").Value Worksheets.Add after:=Worksheets(Worksheets.Count) '★シート追加する命令自体は（以下略） Worksheets(Worksheets.Count).Name = Format(日付, "yyyy_mmdd") '★シートの名前を変える命令自体はマクロの記録で調べられます。 '★オートフィルタで抽出する命令自体はマクロの記録で調べられます .AutoFilter.Range.AutoFilter Field:=3, Criteria1:=">=" & Format(日付, "yyyy/mm/dd"), Operator:=xlAnd, Criteria2:="<=" & Format(日付, "yyyy/mm/dd") '★コピーする命令は（以下略） .Range("E:F").Copy Worksheets(Format(日付, "yyyy_mmdd")).Range("A1") Next 行 '★シートを削除する命令自体はマクロの記録で調べられます Application.DisplayAlerts = False Worksheets("作業用").Delete Application.DisplayAlerts = True End With End Sub （もこな２） 2021/12/22(水) 18:02