『【VBA】可変条件でシートを分かる方法』（ペコパ） VBAに関して質問失礼いたします。 社内システムでの抽出データに、担当者名が記載されています。 マクロにて担当者名毎にシートを分けたいと思っていますが、 難点なのが、担当者名が毎回変わります。 （ある月のデータは、担当者名:A.B.Cですが、 翌月は担当者名:D.E.Fになります。） この様な場合、VBAでシート分けは可能でしょうか。 可能であれば、やり方を教えてください。 ＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞ ---- レイアウトも現状のコードの提示もないので当てずっぽう。 (1)担当者欄を見る (2)担当者A.B.C　だったらシート１に貼付 担当者D.E.F　だったらシート２に貼付 (3)行数？分繰り返す でできませんか＞ （もこな２ ） 2020/03/09(月) 18:54 ---- 説明不足で申し訳ありません。 以下のようなレイアウトのエクセル表があります。 担当者名ごとにシートを分けたいと思ってますが、 今月は担当者がA,B,C、来月はD,E,Fと毎月担当者が変わります。 名前が未知の新規担当者も入ってくる可能性があります。 この場合、該当月の担当者名を取得し、 VBAで担当者名毎にシートを分けることは可能でしょうか。 構文も教えていただけると助かります。 以下「Macro1」は、マクロ記録で下表をシート分けした構文です。 （構文は可変にはなっていません） この構文を一部つかえるのであれば、その部分を変更したらいいかなど、 ご教授いただけると助かります。 担当者名 商品コード 品名 売上 A 0070062 ガーベラ 11,111 B 0964342 バラ 33,333 B 0686019 チューリップ 555 C 0070062 ミモザ 6,666 C 0070062 カーネーション 4,444 C 0367325 アネモネ 5,555 Sub Macro1() ' ' Macro1 Macro ' ' Range("A1").Select Selection.AutoFilter ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1, Criteria1:="A" ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1 Range("A2").Select ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1, Criteria1:="A" Cells.Select Selection.Copy Sheets.Add After:=ActiveSheet ActiveSheet.Paste Sheets("Sheet2").Select Cells.Select Sheets("Sheet2").Name = "A" Sheets("Sheet1").Select ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1, Criteria1:="B" Cells.Select Application.CutCopyMode = False Selection.Copy Sheets.Add After:=ActiveSheet Sheets("Sheet3").Select Sheets("Sheet3").Name = "B" ActiveSheet.Paste Range("E10").Select Sheets("Sheet1").Select ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1, Criteria1:="C" Cells.Select Application.CutCopyMode = False Selection.Copy Sheets.Add After:=ActiveSheet Cells.Select ActiveSheet.Paste Sheets("Sheet4").Select Sheets("Sheet4").Name = "c" Sheets("Sheet1").Select Range("F7").Select ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1 Range("A1").Select End Sub よろしくお願いいたします。 （ペコパ） 2020/03/09(月) 20:51 ---- 参考に Sub Test() Dim myDic As Object, d As Variant Dim LastCell As Range, c As Range Set myDic = CreateObject("Scripting.Dictionary") With ActiveSheet Set LastCell = .Cells(Rows.Count, "D").End(xlUp) For Each c In .Range("A2", .Cells(Rows.Count, "A").End(xlUp)) myDic(c.Value) = Empty Next For Each d In myDic.keys 'シートの有無確認 If CheckSheet(d) = False Then '無ければ追加 Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = d End If .Range("A1").AutoFilter Field:=1, Criteria1:=d .Range("A2", LastCell).Copy Worksheets(d).Cells(Rows.Count, "A").End(xlUp).Offset(1) Next .AutoFilterMode = False .Activate End With End Sub Function CheckSheet(strSN As Variant) As Boolean Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.Name = strSN Then CheckSheet = True Exit For End If Next End Function （ピンク） 2020/03/09(月) 22:11 ---- ピンク様 有難うございます！！！ やりたいことができました。 感動しました。。。 すごいです。この構文、大事にとっておきます。 本当にありがとうございます。 （ペコパ） 2020/03/09(月) 22:52 ---- 既に回答ついてますが、↓のような表であれば、発想は提示されたような感じでよいとおもいます。 _____A___________B__________C______________D_________ 1 担当者名 商品コード 品名 売上 2 A 0070062 ガーベラ 11,111 3 B 0964342 バラ 33,333 4 B 0686019 チューリップ 555 5 C 0070062 ミモザ 6,666 6 C 0070062 カーネーション 4,444 7 C 0367325 アネモネ 5,555 ポイントは、 (1) なんとかして、担当者名の重複しないリストを作成する (2) 担当者名のシートが無ければ作成する (3) データ元シートで、オートフィルタを使って担当者名で抽出する (4) 抽出されたものをコピーして、担当者名のシートに貼付する (5) (2)〜(4)を繰り返す。 という処理をどうやって組み立てるかだとおもいます。 このうち、(1),(3),(4)については、（アプローチによっては）マクロの記録でヒントとなるコードが得られます。 また、 (1)については http://officetanaka.net/excel/vba/tips/tips80.htm (2)については http://officetanaka.net/excel/vba/tips/tips10.htm https://mmm-program.com/vba-sheet-exist/ (3)については http://officetanaka.net/excel/vba/tips/tips155.htm などが参考になると思いますので、興味があればチャレンジしたり読んでみてはどうでしょうか。 長くなりましたが、最後に研究用のコードを提供します。 こちらも、興味があれば【ステップ実行】して、何をやっているのか研究してみてください、 ※ステップ実行ってなんだ？という場合はこちらをご覧ください。 　https://www.239-programing.com/excel-vba/basic/basic023.html 　http://marupeke296.com/DBG_No1_Step.html ※ブレークポイントってなんだ？という場合はこちらをご覧ください。 https://www.tipsfound.com/vba/01010 https://www.239-programing.com/excel-vba/basic/basic022.html Sub 研究用02() Dim 作業用SH As Worksheet Dim データSH As Worksheet Dim 出力用SH As Worksheet Dim i As Long, 最終行 As Long Stop '←ブレークポイントの代わり '▼データのあるシートを変数にセット Set データSH = ActiveSheet '▼作業用シートを作成して変数にセット Set 作業用SH = Worksheets.Add(before:=Worksheets(1)) '▼作業用シートに担当者名の重複しないリストを作成 データSH.Range("A:A").Copy 作業用SH.Range("A1") 作業用SH.Range("A1").RemoveDuplicates Columns:=1, Header:=xlYes '▼作業用シートの2行目から最終行まで順番にループ処理 最終行 = 作業用SH.Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To 最終行 '▼出力用のシートを準備 Set 出力用SH = Nothing On Error Resume Next Set 出力用SH = Worksheets(作業用SH.Cells(i, "A").Value) On Error GoTo 0 If 出力用SH Is Nothing Then Set 出力用SH = Worksheets.Add(after:=Worksheets(Worksheets.Count)) 出力用SH.Name = 作業用SH.Cells(i, "A").Value End If '▼データのあるシートでオートフィルタを実行して抽出 データSH.Range("A1").AutoFilter Field:=1, Criteria1:=作業用SH.Cells(i, "A").Value '▼抽出したものをコピペ データSH.AutoFilter.Range.Copy 出力用SH.Range("A1") Next i '▼後処理 Application.DisplayAlerts = False 作業用SH.Delete データSH.AutoFilterMode = False Application.DisplayAlerts = True End Sub （もこな２） 2020/03/10(火) 08:42 ---- もこな２様 とても分かりやすい解説、誠にありがとうございます！！ 研究用のコード、とても助かります。 早速勉強させていただきました。 1点質問なのですが、現コードではA列の項目別にシート分けして頂いておりますが、 例えばA→G列に変更になった場合はシート分けは可能なのでしょうか。 TRYしてみたのですが、一応シート分けはできたのですが、 ファイル内のタイトル行以下の必要情報が反映しませんでした。 A列（左端列）にないと、うまいこと分けるのは厳しい等、 ルールはありますでしょうか。 何度も聞いて申し訳ありませんが、ご教授いただけましたら幸いです。 （なみ） 2020/03/10(火) 23:06