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

質問

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

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

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

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

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

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

回答No.5

tom04 · ベストアンサー

続けてお邪魔します。

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

お礼

ありがとうございます。再現できました。
VBAはいろんなことができるのですね。
勉強してみます。

シートは手作業でつくる場合も知りたくなったので
新たに別に質問させてもらおうと思います。
ありがとうございました。

回答No.4

tom04

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

お礼

ありがとうございます！できました！

しかし使ってみてわかったのですが、
いくつか気になる点が

・新しく作成されたシートの番号欄は再び1から表示するようにしたい。
・入力シート（今はsheet1）で消した値や行は作成されたシートでも消えるようにしたい。

　ex.バックスペースで地区に入力した値を消す
　　　→作成されたシートの対応する値も消える

・新しく作成されたシートの行列の幅は入力シートと同じにしたい。

これらが出来る方法はあるでしょうか。
それぞれのシートを個別に編集したほうが早いのかもしれませんが。
ちなみに簡易化するためにVBAの値のEをCに、5を3に、編集して、3列で試しています。

回答No.2

tom04

こんばんは！

＞自動で別シート作成およびデータ出力したい
自動で別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

お礼

ありがとうございます

列は左から
番号、氏名、都道府県、市区町村、地区、番地

となっていますので地区はE列(5列目)です。
しかし他人に使ってもらうと列などの増減も考えられますので、
変化に対応できるものであればいうことありません。
差し当たり地区はE列で作成したいです

回答No.1

aokii

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

お礼

ありがとうございます。
ただこのexcelファイルはPCの得意でない他人に使ってもらうためのものであり、
単に言葉を入力した時点で自動的に・・・
ということが必要です。

私自身もピボットテーブルを使ったことがなく、
他人に教えることはできません。

何か方法はないでしょうか。