Excel 別シートに自動で抽出するには・・・？

質問

Excelの質問です。
基本のシートに都度入力されていくデータを、自動で別シートに抽出する方法がどうしてもわからないので、どなたか教えて下さい・・・m(_゛_；)m

【Seet1】基本シート　※　都度入力します
　　　A　　　　B　　　　　C　　　　　D
1　08.9.1　　渡辺　　ジャケット　　80,000-
2　08.9.1　　小沢　　スカート　　　30,000-
3　08.9.2　　二宮　　パンツ　　　　40,000-
4　08.9.3　　渡辺　　ブラウス　　　20,000-

【seet2】渡辺シート　基本シートに入力されたと同時に自動に反映
　　　A　　　　B　　　　　C　　　　　D
1　08.9.1　　渡辺　　ジャケット　　80,000-
2　08.9.3　　渡辺　　ブラウス　　　20,000-
3

このようなファイルを完成させたいのですが、どの関数を使用したらよいのか教えて下さい・・・m(_゛_；)m

回答No.4

kigoshi · ベストアンサー

大変失礼しました。
#3のコードにバグがあります。
訂正いたします。

Private Sub Worksheet_Change(ByVal Target As Range)
Const kingakuCol As Integer = 4
Const rowNote As Integer = 5
Dim MySheet As String
Dim rIdx, cIdx As Long

If Target.Column <> kingakuCol Then Exit Sub
Application.EnableEvents = False

On Error GoTo errTrap
MySheet = Cells(Target.Row, 2).Value
If Cells(Target.Row, rowNote).Value = "" Then
rIdx = Sheets(MySheet).Range("A65536").End(xlUp).Row + 1
Cells(Target.Row, rowNote).Value = rIdx
Else
rIdx = Cells(Target.Row, rowNote).Value
End If
For cIdx = 1 To 4
Sheets(MySheet).Cells(rIdx, cIdx).Value = Cells(Target.Row, cIdx).Value
Next
Application.EnableEvents = True
End

errTrap:
If Err.Number = 9 Then
MsgBox "この担当者用シートがありません。"
Else
MsgBox "エラーが発生しました。"
End If
Application.EnableEvents = True
End Sub

お礼

ご丁寧にどうもありがとうございました(*^0^*)！
とても勉強になりました！！

回答No.3

kigoshi

基本シートのシートタブを右クリックし「コードの表示」をクリックします。
右側のエディタエリアに下記コードを貼り付けます。

＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Const kingakuCol As Integer = 4
Const rowNote As Integer = 5
Dim MySheet As String
Dim rIdx, cIdx As Long

If Target.Column <> kingakuCol Then Exit Sub

On Error GoTo errTrap
MySheet = Cells(Target.Row, 2).Value
If Cells(Target.Row, rowNote).Value = "" Then
rIdx = Sheets(MySheet).Range("A65536").End(xlUp).Row + 1
Cells(Target.Row, rowNote).Value = rIdx
Else
rIdx = Cells(Target.Row, rowNote).Value
End If
For cIdx = 1 To 4
Sheets(MySheet).Cells(rIdx, cIdx).Value = Cells(Target.Row, cIdx).Value
Next
Application.EnableEvents = True
End

errTrap:
If Err.Number = 9 Then
MsgBox "この担当者用シートがありません。"
Else
MsgBox "エラーが発生しました。"
End If
Application.EnableEvents = True
End Sub

＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋

金額を入力した時点で、各担当者シートへ転記します。
ご質問では金額の列がＤ列（４列目）になっていますが、変更したいときは
Const kingakuCol As Integer = 4
の数字を変更して下さい。

あとで基本シートのデータを修正したとき各担当者シートで変更する行位置が
必要になるため、各担当者シートの何行目に転記したかを基本シートに記録し
ています。ここではＥ列（５列目）にしていますが、使っていない列であれば、
どこでも良いので、必要に応じて
Const rowNote As Integer = 5
の数字を変更して下さい。

回答No.2

fujillin

基本データの入っているシート名を「基本シート」として、個人別シートのA1セルに検索用の文字列（「渡辺」など）が入っていると仮定します。
また、基本データは1行目からデータがあり、個人別シートへの集計は3行目から行うものとします。

＜シートの参照で行う方法＞
（１）個人別シートのA列（3行目以降）を選択状態で、A3セルに
　　　=IF(基本シート!$B1:$B100=Sheet4!$A$1,基本シート!A1:A100,"")
を入れ、配列数式を設定。（Ctrl+Shft+EnterでFix→式の両側に{ }が付くはずです）
（２）このA列をそのままD列までオートフィル

以上で、A1セルと同じ名前の行だけ抜き出せます。
空白行を詰めるには、オートフィルタで「空白行以外」を選択すれば上詰めにすることができ、ご希望の体裁になると思います。
基本シートのデータが変われば自動的計算で値は反映されますが、オートフィルタの状態だと表示行までは修正されないようです。
新しいデータを表示させるには、「空白行以外」の選択を再度手動で行う必要があります。
（上の（１）の式はデータが100行までを想定してしますので、必要に応じて修正してください。）

＜マクロで行う方法＞
アクティブなシートの集計を行うマクロの例です。
これをループで回せば、個人シート全部の集計を一度に行うことも可能です。
Sub test()
　Dim St0 As Worksheet, St1 As Worksheet
　Dim i As Long, itmp As Long
　Set St0 = Worksheets("基本シート")
　　Set St1 = ActiveSheet
　　itmp = 3 '**転記するスタート行番号
　　For i = 1 To St0.Cells(Rows.Count, 2).End(xlUp).Row
　　　If St0.Cells(i, 2).Value = St1.Cells(1, 1).Value Then
　　　　St1.Cells(itmp, 1).Resize(1, 4).Value = St0.Cells(i, 1).Resize(1, 4).Value
　　　　itmp = itmp + 1
　　　End If
　　Next i
End Sub

こちらの場合は、基本シートに新しい情報を加えてもマクロを実行しない限り、自動的に反映されることはありません。

お礼

マクロ以外のご回答ありがとうございました！！
参考にさせて頂きます(*^0^*)！！

回答No.1

chiune

ワークシート関数だけでは無理だと思います。

以下、補足をお願いいたします。

１）ＶＢＡを使用しても良いですか。
２）各担当者別の名前はどのように指定されますか。
　　たとえば、シート名（シートタブの名前）が渡辺や二宮になっている、
　　あるいはシートのA1セルに担当者名が入っている、など。
３）入力済みのデータに変更があった場合、各担当者シートの内容も連動す
　　る必要がありますか。
４）入力済みのデータを行ごと削除することはあり得ますか。
　　逆に、途中に行挿入することがあり得ますか。

補足

chiune 様

早速のご回答ありがとうございます！

補足を致します。
１）使用して構いません
２）seet名にもそれぞれ〔渡辺〕〔二宮〕と入力し、seet内のA1にも、見出しで〔渡辺〕と入力します
　　※〔〕は入力しません
３）可能ならば連動したいですが、難しいのであれば、手入力で変更するので構いません
４）途中で行削除や、挿入はしません

では、大変お手数ですが、宜しくお願い致します・・・m(_ _;)m