[[20190107123629]]　『条件付きでのSheet振り分け』（シン）　ページの最後に飛ぶ

『条件付きでのSheet振り分け』（シン）

初めて書き込みします。
下記のデータをこれから入力するにあたりいくつか質問があり、ご教授いただけますと幸いです。
なお、PCはほぼ初心者のため至らぬ点が多々ありますが、何卒ご容赦ください。
　　　A　　　　 B　　　　C　　　　D　　　E 　　 F・・・・
１　検査結果　身長　　　体重　　筋力　　下肢長部活の有無
２　陽性　　　　100　　　45　　　20　　　45　　　　あり
３　陰性　　　　120　　　40　　　30　　　50　　　　あり
４　陽性　　　　130　　　50　　　10　　　50　　　　なし
５　陽性　　　　140　　　60　　　20　　　35　　　　なし
６　陰性　　　　125　　　30　　　30　　　40　　　　あり
・
・
・
【質問１】
元データ（Sheet1）に入力していった際に、
同時に、検査結果毎に別シート（Sheet2陽性群、Sheet3陰性群）に振り分けを行うことは可能でしょうか。
行は随時追加されます。
列は必要に応じて削除・追加・修正（切り取り、貼り付け）が考えられます。
＜Sheet2＞
　　　A　　　　 B　　　　C　　　　D　　　E 　　 F
１　検査結果　　身長　　体重　　筋力　　下肢長　　部活の有無
２　陽性　　　　100　　　45　　　20　　　45　　　　あり
３　陽性　　　　130　　　50　　　10　　　50　　　　なし
４　陽性　　　　145　　　60　　　20　　　35　　　　なし
＜Sheet3＞
　　　A　　　　 B　　　　C　　　　D　　　E 　　 F
１　検査結果　　身長　　体重　　筋力　　下肢長　　部活の有無
２　陰性　　　　120　　　40　　　30　　　　50　　　　あり
３　陰性　　　　125　　　30　　　30　　　　40　　　　あり

【質問2】
また、Sheet4に身長・体重・下肢長、Sheet5に筋力と部活の有無の項目に絞って、
同一シート内に検査結果の陽性群、陰性群に分けて記載することは可能でしょうか。
こちらも、生データ（Sheet1）を入力した際に同時に振り分けられるようにできたらと思っております。
また、行・列ともに項目が追加・修正が考えられます。
＜Sheet4＞
　　　A　　　　　B　　　　C　　　　D　　 F　　　　G　　　　H　　I　　　J
１　検査結果　　身長　　体重　　下肢長　　　　検査結果　　身長　　体重　下肢長
２　陽性　　　　100　　　45　　　45　　　　　　　陰性　　120　　　40　　50
３　陽性　　　　130　　　50　　　50　　　　　　　陰性　　125　　　30　　40
４　陽性　　　　145　　　60　　　35　　　
＜Sheet5＞
　　　A　　　　　B　　　　C　　　　D　　 F　　　　G　　　　H　　
I
１　検査結果　　筋力　部活の有無　　　　　　　検査結果　　筋力　部活の有無
２　陽性　　　　20　　　あり　　　　　　　　　　陰性　　　30　　　あり
３　陽性　　　　10　　　なし　　　　　　　　　　陰性　　　30　　　あり
４　陽性　　　　20　　　なし

入力後にこれらを振り分ける方法はサイト等でいくつか試しております。
今回のように、生データ入力後に同時に複数Sheetに自動で入力可能かどうかもわからない状態です。
ご教授のほど何卒よろしくお願い致します。
長文になりましたが、最後まで目を通していただき有り難う御座います。

＜使用 Excel：Excel2016、使用 OS：Windows8 ＞

 まず質問1について。
 Sheet2のA2セルに
 =IFERROR(INDEX(Sheet1!A:A,SMALL(IF(Sheet1!$A$2:$A$1000="陽性",ROW(A$2:A$1000),""),ROW(A1))),"")
 Sheet3のA2セルには上記式の"陽性"部分を"陰性"で入力してShiftキーとCtrlキーを押しながらEnterキーで式を確定
 （確定後、式が{}で囲まれればOK）その後、右及び下へフィルコピーではどうか？
（ねむねむ） 2019/01/07(月) 13:16

 なお上記式はSheet1のデータが1000行まで対応。
 もっと行数がある場合は式中の２か所の$1000を大きくしてくれ。
（ねむねむ） 2019/01/07(月) 13:18

 すまない。
 式を
 =IFERROR(INDEX(Sheet1!A:A,SMALL(IF(INDIRECT("Sheet1!$A$2:$A$1000")="陽性",ROW(A$2:A$1000),""),ROW(A1))),"")
 としてくれ。
 前の式だとSheet1のデータの削除に対応できていなかった。
（ねむねむ） 2019/01/07(月) 13:25

 質問2。
 質問1の式のSheet1!A:Aの部分がSheet1で抜き出してきたい値の列となっているので
 Sheet4およびSheet5の2行目部分にSheet1!A:Aを抜き出したい列に変更して入力し、
 下へフィルコピーしてみてくれ。
 (Shift+Ctrl+Enterを忘れずに）
（ねむねむ） 2019/01/07(月) 13:36

検討中に「ねむねむさん」からご回答がありましたが、書き込みます。

Sheet2!A2: =IFERROR(INDEX(Sheet1!A$2:A$9,SMALL(IF(Sheet1!$A$2:$A$10="陽性",ROW($A$1:$A$9),""),ROW(A1))),"")

Sheet3!:A2 =IFERROR(INDEX(Sheet1!A$2:A$9,SMALL(IF(Sheet1!$A$2:$A$10="陰性",ROW($A$1:$A$9),""),ROW(A1))),"")

両式とも「Ctrl + Shift + Enter」キーで式を入力します。（配列数式）

Sheet4!A2: =IFERROR(INDEX(Sheet2!$A$2:$F$10,ROW(A1),MATCH(A$1,Sheet2!$A$1:$F$1,0)),"")

Sheet4!G2: =IFERROR(INDEX(Sheet3!$A$2:$F$10,ROW(A1),MATCH(A$1,Sheet2!$A$1:$F$1,0)),"")

Sheet5!A2: =IFERROR(INDEX(Sheet2!$A$2:$F$10,ROW(A1),MATCH(A$1,Sheet2!$A$1:$F$1,0)),"")

Sheet5!F2: =IFERROR(INDEX(Sheet3!$A$2:$F$10,ROW(A1),MATCH(A$1,Sheet2!$A$1:$F$1,0)),"")

それぞれの式を、右と下にコピーします。

（メジロ） 2019/01/07(月) 13:54

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    'Sheet1のシートモジュール(Sheet1見出しタブ右クリック　- コードの表示　これを一式貼り付ける)
    Dim c As Range, r1 As Range, r2 As Range
    Application.EnableEvents = False
    Set r1 = Range("A1:F1")
    Set r2 = Range("A1:F1")
    For Each c In Range("A2:A" & Rows.Count).SpecialCells(2)
        If c.Value = "陽性" Then Set r1 = Union(r1, c.Resize(, 6))
        If c.Value = "陰性" Then Set r2 = Union(r2, c.Resize(, 6))
    Next c
    Sheets("Sheet2").Cells.ClearContents
    Sheets("Sheet3").Cells.ClearContents
    Sheets("Sheet4").Cells.ClearContents
    Sheets("Sheet5").Cells.ClearContents
    r1.Copy Sheets("Sheet2").Range("A1")
    r2.Copy Sheets("Sheet3").Range("A1")
    r1.Copy Sheets("Sheet4").Range("A1")
    r2.Copy Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1)
    Sheets("Sheet4").Cells.Copy Sheets("Sheet5").Range("A1")
    Sheets("Sheet4").Columns("D:D").Delete Shift:=xlToLeft
    Sheets("Sheet4").Columns("E:E").Delete Shift:=xlToLeft
    Sheets("Sheet5").Columns("B:C").Delete Shift:=xlToLeft
    Sheets("Sheet5").Columns("C:C").Delete Shift:=xlToLeft
    Application.EnableEvents = True
End Sub
（mm） 2019/01/07(月) 14:10

オートフィルタを使ってちょっと加工すれば2～3分で希望のことはできそうですけど
どうしても、↓がネックなんでしょうか？
＞生データ入力後に同時に複数Sheetに自動で入力

＞入力後にこれらを振り分ける方法はサイト等でいくつか試しております。
とのことですが、その中にオートフィルタを使った方法は入ってるんでしょうか？
すでにオートフィルタは試してみたんだけど、時間がかかるから却下だったということであれば、マクロ作っちゃうとかですかね。
ただ、お持ちのスキルがわからないので、かえってマクロ作るための時間がかかってしまったら本末転倒ですけど・・・

以下、ろくにテストはしてないですけど一例で。

    Sub さんぷる()
        Dim MySh As Worksheet

        'Sheet2～5をクリア
        For Each MySh In Worksheets(Array("Sheet2", "Sheet3", "Sheet4", "Sheet5"))
            MySh.UsedRange.ClearContents
        Next MySh

        With Worksheets("Sheet1")
            'オートフィルタ強制解除
            .AutoFilterMode = False

            '
            'A1セルが含まれる表範囲にオートフィルタを設定してA列を陽性で抽出
            .Range("A1").AutoFilter Field:=1, Criteria1:="陽性"

            '陽性で抽出されたものをコピペ処理
            .AutoFilter.Range.Copy Worksheets("Sheet2").Range("A1")

            Intersect(.AutoFilter.Range, Union(.Range("A:C"), .Range("E:E"))).Copy _
            Worksheets("Sheet4").Range("A1")

            Intersect(.AutoFilter.Range, .Range("A1,D1,F1").EntireColumn).Copy _
            Worksheets("Sheet5").Range("A1")

            '
            'A列を陰性で抽出しなおし
            .Range("A1").AutoFilter Field:=1, Criteria1:="陰性"

            '陰性で抽出されたものをコピペ処理
            .AutoFilter.Range.Copy Worksheets("Sheet3").Range("A1")

            Intersect(.AutoFilter.Range, Union(.Range("A:C"), .Range("E:E"))).Copy _
            Worksheets("Sheet4").Range("G1")

            Intersect(.AutoFilter.Range, .Range("A1,D1,F1").EntireColumn).Copy _
            Worksheets("Sheet5").Range("F1")

            '
            'オートフィルタの抽出状態を解除
            .ShowAllData

        End With

    End Sub

（もこな２） 2019/01/08(火) 00:13

コメント返信：

[ 一覧(最新更新順) ]

[[20190107123629]] 『条件付きでのSheet振り分け』（シン） ページの最後に飛ぶ

[[20190107123629]]　『条件付きでのSheet振り分け』（シン）　ページの最後に飛ぶ