[[20030726021552]]　『オートフィルタの全ての結果を別々シートに』（モモ）　ページの最後に飛ぶ

『オートフィルタの全ての結果を別々シートに』（モモ）

オートフィルタのすべての結果をそれぞれ別シートにしたい。

はじめまして。

過去ログを検索してみたのですが、見つけられなかったので、質問させてください。
オートフィルターをかけ、
それを別シートに値貼り付けしてるデータがあるのですが、
ひとつひとつやるのが大変なんです。

「東京」「大阪」「北海道」「名古屋」…と、地域がもっとたくさんあるのですが、
いちいちオートフィルタで「東京」を選び、コピーして、別シートに貼り付け、
次に「大阪」を選び、コピーしてまた別のシートに貼り付け…
という作業を延々と繰り返してるのですが、とても大変です。

もし、簡単に、地域ごとに別々のシートに分けられる方法があったら
教えてください。
よろしくお願いします。

 VBAでなければ難しいと思います。
Sub test()

  Dim LastR As Long, i As Long

    Application.ScreenUpdating = False
    LastR = Cells(Application.Rows.Count, "A").End(xlUp).Row
    Range("A1:A" & LastR).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Range("A2:A" & LastR).Copy Cells(LastR + 2, 1)
    ActiveSheet.ShowAllData
        For i = Cells(Application.Rows.Count, "A").End(xlUp).Row To LastR + 2 Step -1
            Sheets.Add After:=Worksheets("Sheet1")
            ActiveSheet.Name = Sheets("Sheet1").Cells(i, 1).Value
            Sheets("Sheet1").Select
            Columns("A:N").AutoFilter Field:=1, Criteria1:=Sheets("Sheet1").Cells(i, 1).Value
            Range("A1:N" & LastR).Copy Sheets(Sheets("Sheet1").Cells(i, 1).Value).Range("A1")
        Next i
    Columns("A:N").AutoFilter
    Range("A" & LastR + 2 & ":A" & Cells(Application.Rows.Count, "A").End(xlUp).Row).ClearContents
    Application.ScreenUpdating = False

End Sub

 こんな感じでどうでしょうか？（ケン）

ケンさん　ありがとうございます。

すみません…　教えていただいたのですが、VBA詳しくないのでよくわかりません…

Ｂ7のセルから始まるデータで（オートフィルタはの７行目にかける）
分けたい地域の項目はＥ列に入っている場合、どのように修正すればよいですか？

本当に申し訳ありませんが、ご指導ください…　お願いします。
　
（モモ）

 Sub test()
    Dim LastR As Long, i As Long

    Application.ScreenUpdating = False
    LastR = Cells(Application.Rows.Count, "E").End(xlUp).Row
    Range("E7:E" & LastR).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Range("E8:E" & LastR).Copy Cells(LastR + 2, 5)
    ActiveSheet.ShowAllData

        For i = Cells(Application.Rows.Count, "E").End(xlUp).Row To LastR + 2 Step -1
            Sheets.Add After:=Worksheets("Sheet1")
            ActiveSheet.Name = Sheets("Sheet1").Cells(i, 5).Value
            Sheets("Sheet1").Select
            Columns("B:N").AutoFilter Field:=4, Criteria1:=Sheets("Sheet1").Cells(i, 5).Value
            Range("B7:N" & LastR).Copy Sheets(Sheets("Sheet1").Cells(i, 5).Value).Range("A1")
        Next i

    Columns("B:N").AutoFilter
    Range("E" & LastR + 2 & ":E" & Cells(Application.Rows.Count, "E").End(xlUp).Row).ClearContents
    Application.ScreenUpdating = False

End Sub

 こんなかんじでしょうか？（ケン）

ケンさん　ありがとうございます。

本当に本当に申し訳ないのですが、やってみたら「エラー９　インデックスが有効範囲内にありません」と出てしまいました。エラーの意味もわからないのです…

どのようにしたらいいでしょう？

今後、万が一、今使ってる表が違う構成になった時には、一回目に教えていただいたのと、二回目のやつとで違っている所を参考にして変えれば、応用ききますよね。

ちなみに　 Cells(LastR + 2, 1)　が　Cells(LastR + 2, 5)になっていたり、
("Sheet1").Cells(i, 1).Value　が　("Sheet1").Cells(i, 5).Value　になってる所で、
数字の１が５に変わっているのは、分けたい地域がＥ列（左から５番目）だから、なのですか？（素人考えなので、見当違いの事言ってるかもしれないですね！その時は笑ってください）

本当に質問ばかりで申し訳ありません。
よろしくお願いします。モモ

 一応こちらでは、うまく動いているのですが・・・自分も修行中の身なので一緒に勉強させて
頂ければと、思います。恐らくSheet1のシート名を変更しているのでは・・・
 Sub test()
    Dim LastR As Long, i As Long

    Application.ScreenUpdating = False’ウィンドの固定
    LastR = Cells(Application.Rows.Count, "E").End(xlUp).Row’E列の最終行の取得
    Range("E7:E" & LastR).AdvancedFilter Action:=xlFilterInPlace, Unique:=True’E列の重複した値をフィルターではぶく
    Range("E8:E" & LastR).Copy Cells(LastR + 2, 5)’↑の値をE列の最終行＋２行へ作業せるとしてコピーする
    ActiveSheet.ShowAllData’フィルター解除

        For i = Cells(Application.Rows.Count, "E").End(xlUp).Row To LastR + 2 Step -1
            Sheets.Add After:=Worksheets("Sheet1")’Sheet1の後ろにシートの挿入
            ActiveSheet.Name = Sheets("Sheet1").Cells(i, 5).Value’シート名を変更
            Sheets("Sheet1").Select’Sheet1を選択
            Columns("B:N").AutoFilter Field:=4, Criteria1:=Sheets("Sheet1").Cells(i, 5).Value’B～N列をオートフィルターで抽出
            Range("B7:N" & LastR).Copy Sheets(Sheets("Sheet1").Cells(i, 5).Value).Range("A1")’↑をコピーして先ほど挿入したシートのA1から貼り付け
        Next i

    Columns("B:N").AutoFilter’オートフィルターの解除
    Range("E" & LastR + 2 & ":E" & Cells(Application.Rows.Count, "E").End(xlUp).Row).ClearContents’作業セルの削除
    Application.ScreenUpdating = False

End Sub
こんな感じです。その表はどのような構成になっているのですか？デバックすると黄色くなる
部分があると思いますがどの部分が黄色くなりますか？（ケン）

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

えっと、やはりシート名を変更してました。
シート名を「sheet1」に直してからやったら、うまくできました！本当にありがとうございます！本当に楽になります。

練習をかねて、例えばD列でフィルタをかけたい場合のも、自分で修正してやってみたら、できました！ケンさんに丁寧に解説していただいたおかげで、私も勉強になりました。本当にありがとうございます！

ちなみに、シート名を変更しないでやったら、　Sheets.Add After:=Worksheets("Sheet1")　　の部分が黄色くなりました。やはりシート名が違ってたからなのでしょうか。

ありがとうございます！何度お礼を言っても言い足りないくらいです。

モモ

 過去ログを見ていてこのページをみつけました。
 追加でお聞きしたいのですが、ﾓﾓさんと同じ内容の処理をしたくて
 VBAを書いて実行してみたのですがなぜがエラーになります。
 私は、フィルターをかけたい列にcountif関数を入れているのですが
 VBを実行するとモモさんと同じエラー"「エラー９　インデックスが
 有効範囲内にありませ  ん」が出て、↓この部分が黄色くなります。
 Range("B7:N" & LastR).Copy Sheets(Sheets("Sheet1").Cells(i, 5).Value).Range ("A1")’↑をコピーして先ほど挿入したシートのA1から貼り付け
 sheetの名前も合っているのですが・・・。　　　　　　　　　　　　（星）

 シートレイアウトはどのようになっていますか？（ケン）

 A2のセルから始まるデータで、オートフィルタはの2行目にかける）
分けたい項目はA列に入っていて、且つA列にはB列ﾃﾞｰﾀのcountif式=COUNTIF($B:B,B2)
として集計しています。宜しくお願いします。　　　　　　　（星）

 Sub test()

  Dim LastR As Long, i As Long

    Application.ScreenUpdating = False
    LastR = Cells(Application.Rows.Count, "A").End(xlUp).Row
    Range("A2:A" & LastR).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Range("A3:A" & LastR).Copy Cells(LastR + 2, 1)
    ActiveSheet.ShowAllData
        For i = Cells(Application.Rows.Count, "A").End(xlUp).Row To LastR + 2 Step -1
            Sheets.Add After:=Worksheets("Sheet1")
            ActiveSheet.Name = Sheets("Sheet1").Cells(i, 1).Value
            Sheets("Sheet1").Select
            Columns("A:N").AutoFilter Field:=1, Criteria1:=Sheets("Sheet1").Cells(i, 1).Value
            Range("A2:N" & LastR).Copy Sheets(Sheets("Sheet1").Cells(i, 1).Value).Range("A1")
        Next i
    Columns("A:N").AutoFilter
    Range("A" & LastR + 2 & ":A" & Cells(Application.Rows.Count, "A").End(xlUp).Row).ClearContents
    Application.ScreenUpdating = True

 End Sub
こんな感じでどうでしょう？（ケン）

 回答ありがとうございます。
 しかし、うまくいきません。
 ﾏｸﾛを実行してみると、実行時ｴﾗｰ”13『型が一致しません。』と出てﾃﾞﾊﾞｯｸしてみると
 LastR = Cells(Application.Rows, "A").End(xlUp).Row 
 ↑この部分が黄色くなります。

 A列の型は数値型なのですが、何がダメなのでしょうか？
 A列にcountif関数を入れているのは何か関係がありますか？
 ちなみに、私はExcel2002を使用しているのですが、ﾌｨｰﾙﾄﾞの左上に緑の印がされて
 いて、そのﾌｨｰﾙﾄﾞにﾏｳｽを当てるとどうやら文字列で保存されていますというようなｺﾒﾝﾄが
 でてきます。これも何か関係しているのでしょうか？

 お忙しいところ、申し訳ありませんがまた教えて下さい。　　　　　　　　（星）

 実際にどのようにシート構成されていて何をどうしたいのか、出来るだけ詳しく書いて
頂けないでしょうか。
正直、私のレベルでは実際同じものを作り検証しながら出なければ答えを導けませんので・・・
お恥ずかしい話ですが・・・（ケン）

 いえいえ、こちらこそ説明不足でごめんなさい。
 えっと、まずsheet1の列はA～BSまでﾃﾞｰﾀが入っています。行ﾃﾞｰﾀは500件くらいです。
　　　      A               　　　　B                  C
 1          2                  00052186040
 2          2                  00052186040
 3          3                  00052301228
 4          3                  00052301228
 5          3                  00052301228
 6          2                  00052300043
 7          2                  00052300043
         ↑A列に=countif($B$2:B500,B2)という式をいれて、重複回数を出力しています。
 1行目にのｵｰﾄﾌｨﾙﾀｰをかけてで｢2」を選びｺﾋﾟｰして別のsheetに貼り付け、｢3｣を選び…という
 作業が大変なので簡単にできないかなと思いﾓﾓさんの質問をみつけて似ていたので活用させて
 頂きました。ちなみにﾌｨﾙﾀｰをかけたい行は1行目です。
 こんな説明でおわかりですか？？？　　　　　　　　　　　　　　　　　　　(星）

 Sub test()
    Dim LastR_A As Integer
    Dim LastR_EE As Integer
    Dim i As Integer

    Application.ScreenUpdating = False

    LastR_A = Range("A65536").End(xlUp).Row

    Rows("1:1").Insert Shift:=xlDown
    Range("A1").Value = "重複回数"
    Range("A1:A" & LastR_A).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "EE1"), Unique:=True

    LastR_EE = Range("EE65536").End(xlUp).Row

    For i = 2 To LastR_EE
        Sheets.Add After:=Worksheets("Sheet1")
        ActiveSheet.Name = "重複" & Sheets("Sheet1") _
            .Range("EE" & i).Value & "回"
        Sheets("Sheet1").Select
        Columns("A:BS").AutoFilter Field:=1, Criteria1:=Range("EE" & i).Value
        Range("B2:BS" & LastR_A).Copy Sheets("重複" & Sheets("Sheet1").Range("EE" & i).Value & "回").Range("A1")

    Next i

    Columns("A:BS").AutoFilter
    Columns("EE:EE").Delete Shift:=xlToLeft
    Rows("1:1").Delete Shift:=xlUp

    Application.ScreenUpdating = True

 End Sub
こんな感じでどうでしょうか？（ケン）

 感動しました！！できました！
 すごいですね。速さもすごい早いし。
 ありがとうございます。

 わたしは、VBはまったくわからないのですが使えるようになったらいいなぁと
 少しづつだけど勉強中なんです。
 お手数ですが、もし、意味など教えていただけたら助かります。
 ちなみに、書いていただいたVBでやると重複2回、重複3回・・・というsheetができて、
 ひとつ、重複回というsheetができそのsheetには何にもﾃﾞｰﾀがはいっていなかったのですが
 どうしてもそういうsheetができてしまうのでしょうか？
 それから、もうひとつ、お願いがあるのですが、重複回数が6回以上の場合は１つのSheet
 にまとめてデータを貼り付けたいのですが、そういう事ってできますか？
 わがまま言って申し訳ありません。宜しくお願いします。　　　　　　（星）

 Sub test()
    Dim LastR_A As Integer
    Dim LastR_EE As Integer
    Dim i As Integer

    Application.ScreenUpdating = False  'ウィンドウの固定

    LastR_A = Range("A65536").End(xlUp).Row  'A列の最終行の取得

    Rows("1:1").Insert Shift:=xlDown  '1行目に行を挿入
    Range("A1").Value = "重複回数"  'A1に重複回数と入れているだけ。ラベルなら何でも良い。
    Range("A1:A" & LastR_A).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "EE1"), Unique:=True  'A列の回数をEE列に重複を無視して抽出

    LastR_EE = Range("EE65536").End(xlUp).Row  'EE列の最終行の取得

    For i = 2 To LastR_EE
        Sheets.Add After:=Worksheets("Sheet1") 'Sheet1の後ろにシートの挿入
        ActiveSheet.Name = "重複" & Sheets("Sheet1") _
            .Range("EE" & i).Value & "回" '挿入したシートの名前の変更
        Sheets("Sheet1").Select  'シート1を選択
        Columns("A:BS").AutoFilter Field:=1, Criteria1:=Range("EE" & i).Value 'A列のオートフィルタでEE列の値を抽出
        Range("B2:BS" & LastR_A).Copy Sheets("重複" & Sheets("Sheet1").Range("EE" & i).Value & "回").Range("A1") 'B2:BSの最終行までコピーにて作ったシートに貼付け

    Next i

    Columns("A:BS").AutoFilter 'オートフィルタの解除
    Columns("EE:EE").Delete Shift:=xlToLeft  'EE列の削除
    Rows("1:1").Delete Shift:=xlUp  '1行の削除

    Application.ScreenUpdating = True 'ウィンドウの固定解除

 End Sub
かんな感じです。
＞重複回というsheetができ
多分私の作ったシートレイアウトと貴方のと違うのでしょう。
6回以上も可能です。私もまだVBAを始めたばかりです。一緒に頑張りましょう。（ケン）

 ありがとうございます。なるほど！
 すごくわかりやすいです。
 sheetの件は、自分なりに考えて頑張ってみます！！
 早速なのですが、6回以上はひとつのsheetにする方法を教えていただけますか？
 宜しくお願いします。　　　　　　　　　　　　　　　（星）

 少し追加しただけですが
Sub test()
    Dim LastR_A As Integer
    Dim LastR_EE As Integer
    Dim i As Integer

    Application.ScreenUpdating = False  'ウィンドウの固定

    LastR_A = Range("A65536").End(xlUp).Row  'A列の最終行の取得

    Rows("1:1").Insert Shift:=xlDown  '1行目に行を挿入
    Range("A1").Value = "重複回数"  'A1に重複回数と入れているだけ。ラベルなら何でも良い。
    Range("A1:A" & LastR_A).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "EE1"), Unique:=True  'A列の回数をEE列に重複を無視して抽出

    LastR_EE = Range("EE65536").End(xlUp).Row  'EE列の最終行の取得

    For i = 2 To LastR_EE
        If Range("EE" & i).Value < 6 Then
            Sheets.Add After:=Worksheets("Sheet1") 'Sheet1の後ろにシートの挿入
            ActiveSheet.Name = "重複" & Sheets("Sheet1") _
                .Range("EE" & i).Value & "回" '挿入したシートの名前の変更
            Sheets("Sheet1").Select  'シート1を選択
            Columns("A:BS").AutoFilter Field:=1, Criteria1:=Range("EE" & i).Value 'A列のオートフィルタでEE列の値を抽出
            Range("B2:BS" & LastR_A).Copy Sheets("重複" & Sheets("Sheet1").Range("EE" & i).Value & "回").Range("A1") 'B2:BSの最終行までコピーにて作ったシートに貼付け
        End If
    Next i

    Sheets.Add After:=Worksheets("Sheet1")
    ActiveSheet.Name = "重複6回以上"
    Sheets("Sheet1").Select
    Selection.AutoFilter Field:=1, Criteria1:=">5", Operator:=xlAnd
    Range("B2:BS" & LastR_A).Copy Sheets("重複6回以上").Range("A1")

    Columns("A:BS").AutoFilter 'オートフィルタの解除
    Columns("EE:EE").Delete Shift:=xlToLeft  'EE列の削除
    Rows("1:1").Delete Shift:=xlUp  '1行の削除

    Application.ScreenUpdating = True 'ウィンドウの固定解除

 End Sub
 こんな感じです。（ケン）

 早急にお答え頂いたのにお返事遅くなりました。
 すごいです！自分がしたかった事完璧にできました。
 ありがとうございます。
 ケンさんのVBは簡潔でわかりやすいですね。
 独学ですか？

 また、何かの機会に是非教えて下さい。
 宜しくお願いします。　　　　　　　　　　　　　　　（星）

 >独学ですか？
このエクセルの学校で学びました。ここには、やさしくおもしろい先生方がいっぱい
いらっしゃいますからね。(^_^) （ケン）

 ケンさんへ
 また、追加で質問があるのですが・・・。
 先日、ﾌｨﾙﾀｰ結果が6回以上というのを教えていただいたのですが、
 ﾌｨﾙﾀｰ結果が０と１はsheetにわけなくて良いという条件にしたいのですが。
 それと、sheet1のﾃﾞｰﾀを,作成された各sheet”重複２回”とか3回のsheetのB列から
 貼り付けといて、各sheetのA列には＝countif（C1=C2,"×","○")という関数を
 入れたいのです。
 この処理も、こないだの式に追加で入れていただく事はできますか？

 例）重複2回sheet
         　A               　　　　B                　　　  C
 1　　　　　                　　重複　　　　　　　　ｼﾘｱﾙ番号
 2        ○  　　　　　　　　　2                  00052186040
 3        ×  　　　　　　　　　2                  00052186040
 4        ○　　　　　　　　　  3                  00052301228
 5        ×   　　　　　　　　 3                  00052301228
 6        ×  　　　　　　　　　3                  00052301228
 7        ○　　　　　　　　　  2                  00052300043
 8        × 　　　　　　　　　 2                  00052300043
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　（星）

 もう私レベルではスマートには出来ませんが・・・
 Sub test()
    Dim LastR_A As Integer, LastR_C As Integer
    Dim LastR_EE As Integer
    Dim i As Integer

    Application.ScreenUpdating = False

    Rows("1:1").Insert Shift:=xlDown
    Range("A1").Value = "重複回数"
    LastR_A = Range("A65536").End(xlUp).Row
    Range("A1:A" & LastR_A).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "EE1"), Unique:=True

    LastR_EE = Range("EE65536").End(xlUp).Row

    For i = 2 To LastR_EE
        If Range("EE" & i).Value < 6 And Range("EE" & i).Value > 1 Then
            Sheets.Add After:=Worksheets("Sheet1")
            ActiveSheet.Name = "重複" & Sheets("Sheet1") _
                .Range("EE" & i).Value & "回"
            Sheets("Sheet1").Select
            Columns("A:BS").AutoFilter Field:=1, Criteria1:=Range("EE" & i).Value
            Range("B2:BS" & LastR_A).Copy Sheets("重複" & Sheets("Sheet1").Range("EE" & i).Value & "回").Range("C1")

            Sheets("重複" & Sheets("Sheet1").Range("EE" & i).Value & "回").Select

            LastR_C = Range("C65536").End(xlUp).Row

            Range("A1").Value = "=IF(C1=C2,""×"",""○"")"
            Range("A1").AutoFill Destination:=Range("A1:A" & LastR_C)

            Range("B1").Value = "=COUNTIF(C:C,C1)"
            Range("B1").AutoFill Destination:=Range("B1:B" & LastR_C)

            Sheets("Sheet1").Select

        ElseIf Range("EE" & i).Value = 1 Then
            Sheets.Add After:=Worksheets("Sheet1")
            ActiveSheet.Name = "重複" & Sheets("Sheet1") _
                .Range("EE" & i).Value & "回"
            Sheets("Sheet1").Select
            Columns("A:BS").AutoFilter Field:=1, Criteria1:="<=1", Operator:=xlAnd
            Range("B2:BS" & LastR_A).Copy Sheets("重複" & Sheets("Sheet1").Range("EE" & i).Value & "回").Range("C1")

            Sheets("重複" & Sheets("Sheet1").Range("EE" & i).Value & "回").Select

            LastR_C = Range("C65536").End(xlUp).Row

            Range("A1").Value = "=IF(C1=C2,""×"",""○"")"
            Range("A1").AutoFill Destination:=Range("A1:A" & LastR_C)

            Range("B1").Value = "=COUNTIF(C:C,C1)"
            Range("B1").AutoFill Destination:=Range("B1:B" & LastR_C)

            Sheets("Sheet1").Select

       End If
    Next i

    Sheets.Add After:=Worksheets("Sheet1")
    ActiveSheet.Name = "重複6回以上"
    Sheets("Sheet1").Select
    Selection.AutoFilter Field:=1, Criteria1:=">5", Operator:=xlAnd
    Range("B2:BS" & LastR_A).Copy Sheets("重複6回以上").Range("C1")

    Sheets("重複6回以上").Select

    LastR_C = Range("C65536").End(xlUp).Row

    Range("A1").Value = "=IF(C1=C2,""×"",""○"")"
    Range("A1").AutoFill Destination:=Range("A1:A" & LastR_C)

    Range("B1").Value = "=COUNTIF(C:C,C1)"
    Range("B1").AutoFill Destination:=Range("B1:B" & LastR_C)

    Sheets("Sheet1").Select

    Columns("A:BS").AutoFilter
    Columns("EE:EE").Delete Shift:=xlToLeft
    Rows("1:1").Delete Shift:=xlUp

    Application.ScreenUpdating = True

 End Sub
こんな感じです。誰かがもっとスマートな方法を教えてくれるといいですね。
私も勉強になるし・・・（ケン）

 お返事遅くなって申し訳ありません。
 おかげさまでうまくいきました。
 自分なりに意味を書いてみたりして、内容を把握していってみます。
 どうもありがとうございました。
 また、お願いします。　　　　　　　　　　　　　　　（星）

過去ﾛｸﾞを見て、この内容に追加する形になると思うのですが
教えていただきたい事がございます。
現在、ﾓﾓさんが書かれているようなﾌｨﾙﾀｰで抽出したﾃﾞｰﾀをｼｰﾄ名にするというＶＢを
作成しています。

Dim LastR As Long, i As Long

    Application.ScreenUpdating = False 'ウィンドの固定

    LastR = Cells(Application.Rows.Count, "B").End(xlUp).Row 'E列の最終行の取得
    Range("B3:B" & LastR).AdvancedFilter Action:=xlFilterInPlace, Unique:=True 'E列の重複した値をフィルターではぶく
    Range("B4:B" & LastR).Copy Cells(LastR + 2, 2) '↑の値をE列の最終行＋２行へ作業せるとしてコピーする

    ActiveSheet.ShowAllData 'フィルター解除

        For i = Cells(Application.Rows.Count, "B").End(xlUp).Row To LastR + 2 Step -1
            Sheets.Add After:=Worksheets("Sheet1") 'Sheet1の後ろにシートの挿入
            ActiveSheet.Name = Sheets("Sheet1").Cells(i, 2).Value 'シート名を変更
            Sheets("Sheet1").Select 'Sheet1を選択
            Columns("B:N").AutoFilter Field:=1, Criteria1:=Sheets("Sheet1").Cells(i, 2).Value 'B～N列をオートフィルターで抽出
            Range("B3:N" & LastR).Copy Sheets(Sheets("Sheet1").Cells(i, 2).Value).Range("A1") '↑をコピーして先ほど挿入したシートのA1から貼り付け
        Next i

         Columns("A:N").AutoFilter 'オートフィルターの解除
         Range("B" & LastR + 2 & ":B" & Cells(Application.Rows.Count, "B").End(xlUp).Row).ClearContents '作業セルの削除
         Application.ScreenUpdating = True

この処理をする前に、同じVBの中で、Sheet1のﾃﾞｰﾀを、ｴｸｾﾙ機能のﾃﾞｰﾀ>集計というツール
で集計した後に、その集計形式のままで上に書いているVBを走らせて、シート分けをするということは可能でしょうか？
もしくは、VBを走らせてシート分けした後に、それぞれ分けられたシートで集計形式にしたいのですが、そういう式をVBに加えることはできますか。。。
集計の基準はすべて同じです。
宜しくお願いします。（やま）

私もとても勉強になりました。
ありがとうございました。
(yoshi)

コメント返信：

[ 一覧(最新更新順) ]

[[20030726021552]] 『オートフィルタの全ての結果を別々シートに』（モモ） ページの最後に飛ぶ

[[20030726021552]]　『オートフィルタの全ての結果を別々シートに』（モモ）　ページの最後に飛ぶ