Excel　抽出したデータで別シート自動作成

Question

Excelで、条件で抽出したデータを、自動で別シート作成およびデータ出力したい

外部サイトで恐縮ですが、
こちら　→　http://oshiete1.nifty.com/qa6295795.html　　　の内容が似ているとは思いますが、

シートの自動作成まで含めるとどうなるのでしょうか

添付画像のように、
sheet1に（画像ではすでに入力済みですが）、たとえば　地区　列に「え」と入力すると
【え】というシートが自動作成の上、地区え　の行が出力される
次に「え」と入力すると同シートの次の行に出力される

【い】というシートも同様です。

このようにするにはどうすればいいのでしょうか？
事情により急いでいます。何卒よろしくお願いいたします。

tom04 · Accepted Answer

続けてお邪魔します。

No.4の
（1）新しく作成されたシートの番号欄は再び1から表示するようにしたい。
（2）入力シート（今はsheet1）で消した値や行は作成されたシートでも消えるようにしたい。
　ex.バックスペースで地区に入力した値を消す
　　　→作成されたシートの対応する値も消える
（3）新しく作成されたシートの行列の幅は入力シートと同じにしたい。

の件について
（1）
今までのコードはSheet名を「地区」名にするようにしていましたので
「番号欄は再び1から・・・」というのがよくわからないのですが、
とりあえずは入力順にSheetが追加されるはずですので手作業でSheet見出しをドラッグして
順番を入れ替えてみてください。
（もちろんコードでSheetを並び替えることも可能ですが、そんなにたびたび並び替える必要はなさそうなので）

（2）と（3）
コードをやり替えてみました。
まず前回の「標準モジュール」のコードをすべて削除して↓のコードにしてください。

Sub Sheet分け() 'この行から
    Dim k As Long, str As String, wS As Worksheet, myFlg As Boolean
    Set wS = Worksheets(1)
    str = wS.Cells(Selection.Row - 1, "E")
    Application.ScreenUpdating = False
    For k = 2 To Worksheets.Count
        If Worksheets(k).Name = str Then
            myFlg = True
            Exit For
        End If
    Next k
    If myFlg = False Then
        Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = str
    End If
    Worksheets(str).Cells.ClearContents
    With wS.Range("A1")
        .AutoFilter field:=5, Criteria1:=str
        .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
        Worksheets(str).Activate
        ActiveSheet.Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteColumnWidths
        Selection.PasteSpecial Paste:=xlPasteAll
    End With
    wS.AutoFilterMode = False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    wS.Activate
End Sub 'この行まで

次にSheet1のシートモジュールもすべて削除し、↓のコードにしてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
    Dim i As Long, j As Long, lastCol As Long, str As String
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    i = Target.Row
    j = Target.Column
    If j <= lastCol And Target.Count = 1 Then
        If Target <> "" Then
            Call Sheet分け
        Else
            str = Cells(Target.Row, "E")
            Worksheets(str).Cells.ClearContents
            Range("A1").AutoFilter field:=5, Criteria1:=str
            Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
                Worksheets(str).Range("A1")
            AutoFilterMode = False
        End If
    End If
End Sub 'この行まで

※　E列データを消去してしまうとフィルタがかけられませんので、エラーになってしまいます。
※　今回もE列「地区」？でフィルタを掛けてE列をSheet名としています。

今度はどうでしょうか？m(_ _)m

tom04 · Answer

No.2です。

＞地区はE列(5列目)です。
＞しかし他人に使ってもらうと列などの増減も考えられますので・・・

というコトですが、E列の「地区」は列・行が増えても変更がない！という前提です。

前回の「標準モジュール」のコードをすべて削除して↓に変更してみてうください。
（Sheetモジュールの方はそのままです）

Sub Sheet分け() 'この行から
    Dim k As Long, str As String, wS As Worksheet, myFlg As Boolean
    Set wS = Worksheets(1)
    str = wS.Cells(Selection.Row - 1, "E") '←ココをE列に変更
    For k = 2 To Worksheets.Count
        If Worksheets(k).Name = str Then
            myFlg = True
            Exit For
        End If
    Next k
    If myFlg = False Then
        Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = str
    End If
    Worksheets(str).Cells.ClearContents
    With wS.Range("A1")
        .AutoFilter Field:=5, Criteria1:=str    '←E列でフィルタ
        .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Worksheets(str).Range("A1")
    End With
    wS.AutoFilterMode = False
End Sub 'この行まで

これで列が増えても対応できると思います。
今回はE列でオートフィルタを掛けています。

※　今回もA～最終列まで入力されて（空白セルがなくなった状態で）初めてマクロが実行されるようにしています。m(_ _)m

tom04 · Answer

こんばんは！

＞自動で別シート作成およびデータ出力したい
自動で別Sheet作成となるとVBAになってしまいます。

アップされている画像が小さすぎて詳細が判らないのですが、
とりあえずやり方だけ・・・

入力用のSheetはSheet見出しの一番左側に配置してあるとします。
勝手に表のレイアウトは↓の画像のようにしています。

まず　Alt＋F11キー　→　メニュー　→　挿入　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペーストしてExcel画面に戻ってください。

Sub Sheet分け() 'この行から
    Dim k As Long, str As String, wS As Worksheet, myFlg As Boolean
    Set wS = Worksheets(1)
    str = wS.Cells(Selection.Row - 1, "B") '←B列の選択セル行より1行上のB列データ
    For k = 2 To Worksheets.Count
        If Worksheets(k).Name = str Then
            myFlg = True
            Exit For
        End If
    Next k
    If myFlg = False Then
        Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = str
    End If
    Worksheets(str).Cells.ClearContents
    With wS.Range("A1")
        .AutoFilter field:=2, Criteria1:=str    '←B列でオートフィルタを掛けている
        .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Worksheets(str).Range("A1")
    End With
    wS.AutoFilterMode = False
End Sub 'この行まで

次にSheet見出しの一番左側（操作したいSheet見出し）上で右クリック　→　コードの表示　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りSheet1？にデータを入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
    Dim i As Long, j As Long, lastCol As Long
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    i = Target.Row
    j = Target.Column
    If j <= lastCol And Target.Count = 1 Then
        If WorksheetFunction.CountBlank(Range(Cells(i, "A"), Cells(i, lastCol))) = 0 Then
            Call Sheet分け
        End If
    End If
End Sub 'この行まで

※　入力用Sheetのすべての項目列が埋まらないとマクロが実行されないようにしています。
※　画像ではB列に「地区」のデータを入力するという前提です。

今回重要なのは「地区」の列がどこか？というコトなのですが
画像ではそれが判断できませんので、勝手にB列としています。
VBAの場合、1行・1列でも違えば全く意味のないものになりますので、
詳細が判れば具体的なアドバイスができると思います。m(_ _)m

aokii · Answer

ピボットテーブルではいかがでしょう。

Excel 抽出したデータで別シート自動作成

続けてお邪魔します。

No.2です。

こんばんは！

ピボットテーブルではいかがでしょう。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

Excel　抽出したデータで別シート自動作成