[[20210403081035]]　『「オートフィルタの全ての結果を別々シートに」[メx（てんちゃん）　ページの最後に飛ぶ

『「オートフィルタの全ての結果を別々シートに」[モモ]　について』（てんちゃん）

投稿
[[20030726021552]] 『オートフィルタの全ての結果を別々シートに』（モモ）　
について...

過去ログを見て、質問があり投稿しました。
やまさんの質問と同一になりますが、それに対する具体的な回答が見当たらなかったので投稿します。

モモさんが質問した内容でケンさんが回答したマクロで無事できました。
そこで、追加で作業したいことがあります。
1.@このマクロを走らせて別々にシート分けした後に、それぞれ分けられたシートで集計形式（エクセルのデータの小計を入れたい）にしたい
2.上記1のあとにその表のセル全体に縦横全部黒い罫線を引きたい
　(エクセルならctrl +aでセルが入っている表を選択し縦横全部黒線をいれるのですが)

A1からM列までデータが入っており、M列の企業名をオートフィルタで選択しNEWシートへA1からMまでコピーしています。
NEWシートへコピーしたあとの集計設定は、エクセルのデータの小計で言うと、
グループ基準がA列の仕入先、集計の方法は合計、集計するフィールドはI列の支払金額、現在の小計をすべて置き換えるにチェック、集計行をデータの下に挿入するにチェックしOK選択した状態と同じものにしたいです。

そういう式以下ののマクロに追加可能ですか。
ご教示お願いいたします。

Sub test()

    Dim LastR As Long, i As Long
    Application.ScreenUpdating = False
    LastR = Cells(Application.Rows.Count, "M").End(xlUp).Row
    Range("M1:M" & LastR).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Range("M2:M" & LastR).Copy Cells(LastR + 2, 13)
    ActiveSheet.ShowAllData
        For i = Cells(Application.Rows.Count, "M").End(xlUp).Row To LastR + 2 Step -1
            Sheets.Add After:=Worksheets("加工")
            ActiveSheet.Name = Sheets("加工").Cells(i, 13).Value
            Sheets("加工").Select
            Columns("A:M").AutoFilter Field:=13, Criteria1:=Sheets("加工").Cells(i, 13).Value
            Range("A1:M" & LastR).Copy Sheets(Sheets("加工").Cells(i, 13).Value).Range("A1")
        Next i
    Columns("A:M").AutoFilter
    Range("M" & LastR + 2 & ":M" & Cells(Application.Rows.Count, "M").End(xlUp).Row).ClearContents
    Application.ScreenUpdating = False
End Sub

＜使用 Excel：Office365、使用 OS：Windows10 ＞

 こんにちは！
 記録ばっかりお勧めして申し訳ございませんが、取り敢えず記録出来るのなら記録してそれを叩き台にされてみてはどうでしょうか？

 >グループ基準がA列の仕入先、集計の方法は合計、
 >集計するフィールドはI列の支払金額、
 >現在の小計をすべて置き換えるにチェック、
 >集計行をデータの下に挿入するにチェックしOK選択した状態
 >と同じものにしたいです。

 他にいい回答がつくといいですね(^^;
（SoulMan） 2021/04/03(土) 14:33

 ＞Excel：Office365

 そのバージョンだとUNIQUE関数が使えるんじゃないかと思うんですが、
 どこかの空いているセルに = U　と1文字を入力しただけで、UNIQUE関数が候補の中に現れないですか？

（半平太） 2021/04/03(土) 15:33

 ＞グループ基準がA列の仕入先

 それに関してですが、データはこの処理をする前から
 仕入先を基準に並べ替えが済んでいる状態なんでしょうか？

（半平太） 2021/04/03(土) 16:09

SoulManさん、コメントありがとうございます。
みなさんお優しい方ばかりでアドバイス本当にありがとうございます。
記録したものをコピーペーストしてみたのですが、「リストまたは選択範囲のどの行に列見出しが含まれているかを特定できません。コマンドを実行するには、行を特定する必要があります。」とメッセージが出てくるので、OKを何回か押すと、
「実行エラー1004 アプリケーション定義またはオブジェクト定義のエラーです」とエラーメッセージが出てしまい、デバッグを確認するとActiveSheet.Name = Sheets("加工").Cells(i, 13).Valueが黄色くなります。
コードは以下です。Next iの手前に追加しました。
枕初心者でどうしたらいいかわかりません。

For i = Cells(Application.Rows.Count, "M").End(xlUp).Row To LastR + 2 Step -1

            Sheets.Add After:=Worksheets("加工")
            ActiveSheet.Name = Sheets("加工").Cells(i, 13).Value
            Sheets("加工").Select
            Columns("A:M").AutoFilter Field:=13, Criteria1:=Sheets("加工").Cells(i, 13).Value
            Range("A1:M" & LastR).Copy Sheets(Sheets("加工").Cells(i, 13).Value).Range("A1")

　　　ActiveSheet. Range("A1").Select

           Selection.Subtotal GroupBy:1 ,Function:=xl Sum,TotalList:=Array（9）, _ Replace:=True, Page Breaks:=False,  Summary BelowData:=True
        Next i

（てんちゃん） 2021/04/03(土) 17:12

半平太さん、コメントありがとうございます。
=Uを試してみたのですがマクロも関数も初心者のため、なんだかよくわかりませんでした。

また、2つ目のコメントもありがとうございます！
＞グループ基準がA列の仕入先
ですが、繰り返しのデータ処理をする手前でA列で並べ替えしております。

みなさん、本当にいろいろアドバイスありがとうございます。

またアドバイスありましたらどんなことでも構いませんのでよろしくお願いします。
（てんちゃん） 2021/04/03(土) 17:19

 シートのレイアウトとシートの関係がよくわからないのでほとんどブラインドExcelですけど。。。

 もう少し変数を使うなどしてSheetからちゃんと明示するようにした方が良いと思います。
それとシートを追加するのは
If Not Evaluate("=ISREF('" & Sheets("加工").Cells(i, "M").Value & "'!A1)") Then Sheets.Add.Name = Sheets("加工").Cells(i, "M").Value
がお勧めです。

 これでも↓動かないんですけど、、、何かのヒントになれば幸いです。。。

 Option Explicit
Sub kk()
Dim LastR As Long
Dim i As Long
LastR = 30
With Sheets("加工")
    For i = .Cells(Rows.Count, "M").End(xlUp).Row To LastR + 2 Step -1
        If Not Evaluate("=ISREF('" & Sheets("加工").Cells(i, "M").Value & "'!A1)") Then Sheets.Add.Name = Sheets("加工").Cells(i, "M").Value
            .Columns("A:M").AutoFilter Field:=13, Criteria1:=Sheets("加工").Cells(i, 13).Value
        With Sheets(Sheets("加工").Cells(i, "M").Value)
            .Range("A1").Subtotal groupBy:=1, Function:=xlSum, TotalList:=Array(9), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        End With
    Next i
End With
End Sub
（SoulMan） 2021/04/03(土) 18:16

 よかったらCellsやRangeの前を空白にしないでSheet名を付けてみてください。
こちらで編集してみます。
（SoulMan） 2021/04/03(土) 19:04

 ＞=Uを試してみたのですがマクロも関数も初心者のため、なんだかよくわかりませんでした。

 昔のコードでは、「企業名」の一覧を作る為にAdvancedFilterが使われているのですが、
 最新版のエクセルなら、そんなことをする必要もなくなっているので、
 果たしてそちらのエクセルは最新版なのかどうか確認したかったのですが。。

 そう言う観点からすると、オートフィルタも使う必要がないかも知れない。

 とにかく最新版かどうか知りたいので、どこか空いているセルに

 =SEQUENCE(3)

 と入れてみてください。 それで、そのセルから下に１，２，３と自動的に
 出るかどうか確認していただけませんか。

（半平太） 2021/04/03(土) 19:16

SoulManさん、シートを追加するコードありがとうございます。空白省き、試してみます！

（てんちゃん） 2021/04/04(日) 09:51

半平太さん、ありがとうございます！最初のコメントの意味を今になって理解しました。
空白に=uを入れるとUNIQUE関数の候補が現れ、配列などいれれと一気に行が返されました！
そして、=SEQUENCE(3)を入れると、123と自動で出てきました。こんな関数があるのですね、驚きました。
UNIQUE関数またはSEQUENCE関数はこのあとどのように使えば良いでしょうか。
（てんちゃん） 2021/04/04(日) 10:02

SoulManさん、ありがとうございます。
コード試したところ、デバッグで以下のところが黄色くなりました。
.Columns("A:M").AutoFilter Field:=13, Criteria1:=Sheets("加工").Cells(i, 13).Value
いろいろ試してみたいので、またアドバイスあればよろしくお願いします。
（てんちゃん） 2021/04/04(日) 10:57

 ＞UNIQUE関数またはSEQUENCE関数はこのあとどのように使えば良いでしょうか。

 １．UNIQUE関数は、AdvancedFilter の代わりに使います。
 ２．SEQUENCE関数は、バージョンが最新版か確かめる為だけに出した話題なので、忘れてください。
 ３．AutoFilterは使うことにします。１行目のタイトルもコピーして来れて便利と感じたので。

 Sub test()
     Dim LastR As Long, i As Long
     Dim newSh As Worksheet
     Dim Companies

     Application.ScreenUpdating = False

     LastR = Cells(Application.Rows.Count, "M").End(xlUp).Row
     Companies = Application.unique(Range("M2:M" & LastR))

     For i = UBound(Companies) To 1 Step -1
         Sheets.Add After:=Worksheets("加工")
         Set newSh = ActiveSheet
         newSh.Name = Companies(i, 1)

         With Sheets("加工")
             .AutoFilterMode = False
             .Columns("A:M").AutoFilter Field:=13, Criteria1:=Companies(i, 1)
             .Range("A1:M" & LastR).Copy newSh.Range("A1")
         End With

         additionalOrder newSh
     Next i

     Sheets("加工").AutoFilterMode = False
     Application.ScreenUpdating = True
 End Sub

 Private Sub additionalOrder(newSh As Worksheet)
     Dim newShLastRW As Long

     newShLastRW = newSh.Cells(newSh.Rows.Count, "A").End(xlUp).Row
     With newSh.Range("A1:M" & newShLastRW)
         .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(9), _
         Replace:=True, PageBreaks:=False, SummaryBelowData:=True
     End With

     newShLastRW = newSh.Cells(newSh.Rows.Count, "A").End(xlUp).Row
     With newSh.Range("A1:M" & newShLastRW).Borders
         .LineStyle = xlContinuous
         .Weight = xlThin
     End With
 End Sub

（半平太） 2021/04/04(日) 11:17

 こんにちは！
私のはただただトピ主さんの記録コードを走らせたかっただけなので
半平太　さんの方で進めてください。

 >空白省き、試してみます！
そうではなくて必ず
Range　や　Cellsの前にSheets名を付けてください。
という意味です。

 半平太　さんのコードがすごく参考になると思います。
では、、では、、どうも失礼しました。m(__)m
（SoulMan） 2021/04/04(日) 13:24

半平太さん、早速ありがとうございます！
感動です！半平太さんのコードで私が求めていたシートが出来あがりました！！！
本当に本当にありがとうございます。
お礼をいくら言っても言い足りないくらいです。本当に助かりました。神様のようです！

追加でわがまま聞いてください、お願いします。

加工シートの企業名はマスタシートからvlookupで引っ張ってきており、マスタにないものが#N/Aになります。
#N/Aがあると、実行時エラー"13" 型が一致しません。とでてしまいます。
デバッグはnewSh.Name = Companies(i, 1)が黄色くなります。
#N/Aがあった場合の対処方法なにかありましたらご教示お願いします。

（てんちゃん） 2021/04/04(日) 14:02

SoulManさん、いろいろご教示ありがとうございました！

Range　や　Cellsの前にSheets名を付けてください。という意味です。

なるほど、そうなのですね。わかっておらず、すみませんでした。
マクロの記録を使っていたため、変数の宣言など知らずにやっていましたがみなさんに教えていただいたり自分で調べたりし少し理解ができました。
本当にみなさんお優しいです。
感謝いたします。
（てんちゃん） 2021/04/04(日) 14:10

 ＞#N/Aがあった場合の対処方法なにかありましたら

 #N/Aがあった場合(＝マスタに無い企業）はどうしたいのか、
 その希望を述べて頂かないと始まらないですけども。

 ※例えば、その企業(？）は無視して何も処理しないで欲しいとか。
 　個人的には、マスタを修正するのが本筋だと思っているんですが。。

（半平太） 2021/04/04(日) 14:24

半平太さん、毎度毎度ありがとうございます。

半平太さんが作られたコードのあとにメッセージボックスで"完了しました"と出るようにしています。
#N/Aがあった場合、メッセージボックスで知らせることはできますか？
IF関数でできそうですが、コードのどこに挿入したらいいかがわかりません。
よろしくお願いします。
（てんちゃん） 2021/04/04(日) 16:30

 Sub test()
     Dim LastR As Long, i As Long
     Dim newSh As Worksheet
     Dim Companies
     Dim msg As String

     Application.ScreenUpdating = False

     LastR = Cells(Application.Rows.Count, "M").End(xlUp).Row
     Companies = Application.unique(Range("M2:M" & LastR))

     For i = UBound(Companies) To 1 Step -1

         If WorksheetFunction.IsNA(Companies(i, 1)) Then
             msg = "#N/A あり !" & vbLf
         Else
             Sheets.Add After:=Worksheets("加工")
             Set newSh = ActiveSheet
             newSh.Name = Companies(i, 1)

             With Sheets("加工")
                 .AutoFilterMode = False
                 .Columns("A:M").AutoFilter Field:=13, Criteria1:=Companies(i, 1)
                 .Range("A1:M" & LastR).Copy newSh.Range("A1")
             End With

             additionalOrder newSh
         End If
     Next i

     Sheets("加工").AutoFilterMode = False
     Application.ScreenUpdating = True

     MsgBox msg & "完了しました。"     
 End Sub

（半平太） 2021/04/04(日) 16:59

半平太さん、早速のコメントありがとうございます。
半平太さんのおかげで、望んでいたものができました！
半平太さんは本当に素晴らしいです！！！
神ってます。本当に本当にどうもありがとうございました。
感謝です！感謝しかありません！！
（てんちゃん） 2021/04/04(日) 21:17

コメント返信：

[ 一覧(最新更新順) ]

[[20210403081035]] 『「オートフィルタの全ての結果を別々シートに」[メx（てんちゃん） ページの最後に飛ぶ

[[20210403081035]]　『「オートフィルタの全ての結果を別々シートに」[メx（てんちゃん）　ページの最後に飛ぶ