[[20160321145302]]　『ﾃﾞｰﾀ抽出の方法』（蒔禁稽洌）　ページの最後に飛ぶ

『ﾃﾞｰﾀ抽出の方法』（蒔禁稽洌）

ﾃﾞｰﾀの抽出方法を自動で　できないものかと思案しています。

ﾃﾞｰﾀとしては下記のような表から抽出したいと考えています。

下記の表を　ｼｰﾄ１　とします

      A   　   B　    　　 C　  　　   D　  　　 　　　　
1   3月1日　　お菓子　　　チョコ　　　2個　　　　
2   3月3日　　野菜　　　　にんじん　　3個
3   3月5日　　お菓子　　　飴　　　　　5個
4   3月6日　　日用品　　　ｼｬﾝﾌﾟｰ　　　1本
5   3月10日　 野菜        ｷｬﾍﾞﾂ　　　 3個

この表から　B列の同じ項目名　たとえば　お菓子で
ｼｰﾄ２に　お菓子のみの表でまとめたいと考えています。（自動）

もし　やり方をご存知のかたおられましたら　教えてください。

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

 ＞（自動）

 同シートでいいなら1行目見出しつけて、オートフィルタ。でいいんでないの？
（GobGob） 2016/03/21(月) 15:33

 衝突

  まず 1行目に列見出しを挿入して、あとはオートフィルタでは？
 >ﾃﾞｰﾀの抽出方法を自動で
 ここは詳しく、何をどうしたときにとか説明しないと...
 そこのところは、自分で考えましょう。
（seiya） 2016/03/21(月) 15:35

 皆さんからも指摘がありますが、【自動】というのは、【どこまで自動】ということを想定しておられますか？

 腕を組んで頭の中で『お菓子』といってみても、パソコンは認識できません。
 "お菓子" というのを　何かの方法でパソコンに伝えるわけですよね。

 簡単な方法の１つがオートフィルターですね。
 ただ、シート1 から シート2 へ抜き出す　ということでしょうから、抽出されたものをコピーして
 シート2 にペーストするという操作が必要になりますが。

 コピペ操作がはいるのはは、自動じゃないからいやだということであればフィルターオプション（フィルター詳細設定）があります。
 この機能を使えば、コピペなしで、シート1から抽出してシート2にセットすることが可能です。

（β） 2016/03/21(月) 16:11

申し訳ございません
説明不足でした。

ﾃﾞｰﾀ入力ｼｰﾄ１があり　ｼｰﾄ１に日々ﾃﾞｰﾀを入力します。
（日々　結構な量のﾃﾞｰﾀを入力します。）

別ｼｰﾄ（ｼｰﾄ２）に　　Ｂ列の項目名別で　抽出された　ﾃﾞｰﾀとしてまとめたいのです。

      A   　   B　    　　 C　  　　   D　  　　 　　E         F       G         H　　
1   3月1日　　お菓子　　　チョコ　　　2個　　　　  3月3日　　野菜　 にんじん　　3個
2   3月5日　　お菓子　　　飴　　　　　5個          3月10日　 野菜   ｷｬﾍﾞﾂ　　　 3個
4   
5

上記のようなまとめ表を作りたいのです。
【自動】でというのは
ｼｰﾄ１にﾃﾞｰﾀを入力すると　ｼｰﾄ２にまとめ表が出来上がるということです。
説明が下手ですが　よろしく御願いします。
大変申し訳ないのですが　こちら　ｵｰﾄﾌｨﾙの使い方もわからないのです。

（蒔禁稽洌） 2016/03/21(月) 16:58

 >>大変申し訳ないのですが　こちら　ｵｰﾄﾌｨﾙの使い方もわからないのです。

 オートフィル　ではなく　オートフィルター　ですけど、これについては是非、習得しておかれたら便利ですよ。
 ネットで検索すると、図解つきの説明ページがいくつもでてきます。
 また、そのあと、是非、フィルターオプションも。これはオートフィルターより、さらに融通性にとんだ抽出ツールです。

 それはともあれ、シート1に入力するだけでシート2ができあがるということですと、シート2に、ぎっしりと数式を埋め込むか
 あるいは、マクロで、たとえば　シート2を開いた瞬間に自動で作成されるという方法が考えられます。

 なんとなく、ご希望は数式処理なんですよね？

（β） 2016/03/21(月) 17:14

 練習してみました。専門家さんから、早晩、スマートな数式が提示されると思いますが。
 作業列も使います。

 Sheet1 の　F1 に　=B1、
 F2 に　=IFERROR(VLOOKUP("*",IF(COUNTIF(F$1:F1,B$1:B$1000)=0,B$1:B$1000),1,FALSE),"")
 これを Ctrl/SHift/Enter で入力して、下にフィルコピー

 Sheet2 の A1 に
 =IFERROR(IF(INDEX(Sheet1!$F:$F,QUOTIENT(COLUMN()-1,4)+1)="","",INDEX(Sheet1!$A$1:$Z$1000,SMALL(IF(Sheet1!$B$1:$B$1000=INDEX(Sheet1!$F:$F,QUOTIENT(COLUMN()-1,4)+1),ROW($B$1:$B$1000)),ROW(A1)),MOD(COLUMN()-1,4)+1)),"")
 これをCtrl/SHift/Enterで入力して、右にずっとフィルコピーし、そのまま下にずずずっとフィルコピー。

（β） 2016/03/21(月) 18:44

 ↑　Sheet2 の日付列は数値で表示されますので、表示書式で適切なものにしてください。
 また、式の中の 1000 は、Sheet1のデータ行数をカバーできる数値にしてください。（１万行なら 10000）

（β） 2016/03/21(月) 18:48

迷惑を掛けないExcel
http://www.shoeisha.co.jp/book/preview/9784798140292

（通りすがり） 2016/03/21(月) 19:04

 通りすがりさんの示唆通り、たとえば数式でも、もっとスマートな（でも、難解な）ものも提示があるかもしれませんが
 蒔禁稽洌さん（なんとお呼びするんでしょうか）と、そのお仲間が数式に詳しく、意味がちゃんと分かりメンテもできるということなら
 大丈夫でしょうけど、そうではないなら、【自動化】はあきらめて、１行目をタイトル行にしてオートフィルターを使い
 お菓子で抽出してSheet2にコピペ、野菜で抽出してSheet2にコピペ、日用品で抽出して・・・・・
 という操作が一番わかりやすくていいと思います。

 コメントしたように、ＶＢＡ処理もできます。たとえば、以下のコード、Sheet2のシートモジュールというところに貼り付けますと
 Sheet2を選択すると、その時点のSheet1の情報から最新の状態にまとめあげます。
 でも、これも、マクロがわからないということになると、【迷惑をかけるエクセル】ということになりますねぇ。

 Private Sub Worksheet_Activate()
    Dim c As Range
    Dim x As Long
    Dim i As Long
    Dim j As Long
    Dim v As Variant
    Dim cat As String
    Dim w As Variant
    Dim dic As Object

    Application.ScreenUpdating = False

    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1").Range("A1").CurrentRegion     '★元シート
        For Each c In .Columns("A").Cells
            cat = c.Offset(, 1).Value
            If Not dic.exists(cat) Then
                If IsArray(v) Then
                    ReDim Preserve v(1 To .Rows.Count, 1 To UBound(v, 2) + 4)
                    x = x + 4
                Else
                    x = 1
                    ReDim v(1 To .Rows.Count, 1 To 4)
                End If
                dic(cat) = Array(0, x)
            End If

            w = dic(cat)
            w(0) = w(0) + 1
            dic(cat) = w
            i = w(0)
            j = w(1)

            v(i, j) = c.Value
            v(i, j + 1) = c.Offset(, 1).Value
            v(i, j + 2) = c.Offset(, 2).Value
            v(i, j + 3) = c.Offset(, 3).Value
        Next
    End With

    UsedRange.ClearContents
    Range("A1").Resize(UBound(v, 1), UBound(v, 2)).Value = v

    Set dic = Nothing

 End Sub

（β） 2016/03/21(月) 19:53

 フィルタリングを順次行ってコピペを繰り返す手順をおすすめしました。
 オートフィルターではなく、フィルターオプションを使えば、直接抽出ができます。
 この操作、もちろん手作業でもたいしたことはないのですが、これをマクロ化したものです。
 先にアップしたコードを消した以下で置き換えてみてください。

 なお、タイトル行はマクロの中で生成し、最後に消しています。

 Private Sub Worksheet_Activate()
    Dim pos As Range

    Application.ScreenUpdating = False

    Me.UsedRange.ClearContents  '転記前にクリア
    Set pos = Range("A1")       '転記開始位置

    With Sheets("Sheet1")
        'タイトル行を作成
        .Rows("1:1").Insert xlDown
        With .Range("A1").CurrentRegion.Columns("A:D")
            .Rows(1).Value = Array("日付", "大分類", "小分類", "数量")
            'B列の一意の値リストを F列に作成
            .Columns("B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("F1"), Unique:=True
            '根のため抽出条件先頭に = を付加して完全一致対応を行う
            With .Range("F2", .Range("F" & Rows.Count).End(xlUp))
                .Value = Application.Text(.Value, "'=@")
            End With
            '抽出ループ処理
            Do While .Range("F2").Value <> ""   '抽出条件
                .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("F1:F2"), CopyToRange:=pos, Unique:=False
                .Range("F2").Delete     '処理済み抽出条件を削除。次の条件がF2に繰り上がる
                Set pos = pos.Offset(, 4)   '次の転記位置。4列右に移動。
            Loop
        End With
        .Rows(1).Delete '元シートに挿入したタイトル行を削除
    End With
    Rows(1).Delete      'できあがったシートのタイトル行を削除
 End Sub

（β） 2016/03/21(月) 21:04

えーと、佳境に入っているところ恐縮ですが、
質問者さま、
オートフィルタ＋　コピーを種類の数だけ実行すればよいだけだと思いますが、
そもそも、シート2の作成意図はなんでしたっけ。

B列のすべての種類について、種類別に表を分けるのですか？
分けた表を　横に並べる必要があるんでしたっけ？
それは印刷のためとかですか？

シート2にコピーして、B列でソートして種類別に見分けられるようにする、
そういった簡単な方法もありますが、それではいけないですか？

別々に印刷したいなら、種類の区切りで改ページすることで対応できそうですけど。

ああ、βさんからいくつも対応案が提示されました。そちらを勉強なさってください。

（以下余談につき、質問者さんはスキップ下さい。）
# 迷惑をかけないExcelですか。
# 私も言及したこともあるんだけど、結構良いこと言っていますよね。
# ただ、現状批判としては首肯できる部分もあるが、改善策の提示は不十分かな。
# 私（田中さん）のセミナーを受講してみたいなことかも。
（γ） 2016/03/21(月) 21:12

 アップした（β） 2016/03/21(月) 21:04　のコードですが、ステップ実行をすると、
 .Range("F2").Delete     '処理済み抽出条件を削除。次の条件がF2に繰り上がる
 ここで、ぐっと時間がかかります。100万行以上のセルの移動ですから、当然といえば当然ですが。
 そこのところをセル削除ではない方法に変更しました。

 Private Sub Worksheet_Activate()
    Dim pos As Range
    Dim c As Range

    Application.ScreenUpdating = False

    Me.UsedRange.ClearContents  '転記前にクリア
    Set pos = Range("A1")       '転記開始位置

    With Sheets("Sheet1")
        'タイトル行を作成
        .Rows("1:1").Insert xlDown
        With .Range("A1").CurrentRegion.Columns("A:D")
            .Rows(1).Value = Array("日付", "大分類", "小分類", "数量")
            'B列の一意の値リストを F列に作成
            .Columns("B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("F1"), Unique:=True
            '抽出ループ処理
            For Each c In .Range("F2", .Range("F" & Rows.Count).End(xlUp))
                .Range("F2").Value = "'=" & c.Value    '抽出条件
                .AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("F1:F2"), CopyToRange:=pos, Unique:=False
                Set pos = pos.Offset(, 4)   '次の転記位置。4列右に移動。
            Next
        End With
        .Rows(1).Delete                 '元シートに挿入したタイトル行を削除
        .Columns("F").ClearContents     '抽出条件列クリア
    End With
    Rows(1).Delete      'できあがったシートのタイトル行を削除
 End Sub

（β） 2016/03/21(月) 22:04

本来の使い方とは違うのかも知れませんがピボットテーブルで。

 １）シート１で１行めに見出し挿入
 ２）シート２にピボットテーブル（表形式）
 ３）項目の数だけコピペで複製
 ４）各ピボットテーブルを項目でフィルター
 ５）見出しが邪魔であれば１行めを非表示

データを追加しても、自動更新されませんが、
「更新」をクリックするだけ。
項目が増えた時は、ピボットもコピペで追加。

（マナ） 2016/03/21(月) 22:29

 読み返してみて、γさんと同じく、横に展開する必要性って？？　と感じました。
 縦に分けるなら、並び替えだけでいいわけですし、γさんがいわれるようにページ替えをすれば
 印刷もわかれます。

 Ｄ列が実際には数値で、その計算（合計とか平均とか）も今後の計画に入っているなら
 並び替えたものを、小計機能で処理すれば、それなりのイメージのものができあがりますし。

（β） 2016/03/21(月) 23:05

コメント返信：

[ 一覧(最新更新順) ]

[[20160321145302]] 『ﾃﾞｰﾀ抽出の方法』（蒔禁稽洌） ページの最後に飛ぶ

[[20160321145302]]　『ﾃﾞｰﾀ抽出の方法』（蒔禁稽洌）　ページの最後に飛ぶ