エクセルで抽出して別ファイル作成するのをマクロを作成したいのですが。

教えていただきたいです。
エクセルで複数シートがありそれぞれのシートには表があり、ある項目のところをフィルタで抽出して別ファイルにして値にして名前をつけて保存させたいのです。
（例）項目を店舗名としたとき、全てのシートに店舗名という項目はあり（表の大きさ、項目の数は異なります）店舗名A商店からG商店があるとして、その店舗ごとに全てのシートそれぞれフィルタして（他店舗は消す）店舗ごとのファイルを名前をつけて値にして保存して作成させたいのです。

今はA商店のファイルを作成するときは項目名のところでフィルタでA商店以外を表示させてまず全部削除したらA商店だけの表になります。その作業をすべてのシートで行い値にして名前を付けて保存していきます。かなり時間かかります。
マクロを作成したいのですが、教えていただけたら助かります。

質問者からの補足コメント

• 

  すみません。アバウトすぎて・・・
  図の元のファイルは上側でシートが３つあります。
  数量シートはC3をフィルタしてA商店に絞ると下側の表になります。
  同様に他の２つのシートも店舗名をフィルタしてA商店で絞りファイル名はA商店として保存します。
  ただし、３つのシートの表は全く同じではなく店舗名の項目も同じ位置ではないです。
  それぞれ同様に商店ごとのファイルを作成させたいのです。
  A商店からF商店まであったとしたら６つのファイルを作成させるということです。
  質問わかっていただけましたでしょうか。

  
    補足日時：2020/04/27 18:34

No.1 回答者： gekikaraou 回答日時： 2020/04/27 13:35

そんなアバウトな質問の仕方では解答は得られないですよ。

プログラム（今回はマクロ）は、どの場所の何をどこからどこまでどのように行う、と言う組み合わせで出来ていますから、それを明確に相手にわかるように画像と文章で伝えないと回答したくても出来ないですよ。

No.2 回答者： fujillin 回答日時： 2020/04/27 13:44

こんにちは

ご質問が抽象的過ぎて（なさりたいことはわかりますが）、とてもコードにはなりません。
せいぜい言えるのは
１）「マクロの記録」機能を利用して、「Ａ商店」についての処理を記録します。
２）できた記録のなかの「Ａ商店」の部分を変数にして、変数の内容を変えれば他の商店に対しても処理できるように変更ます。
くらいでしょうか。

必ずしも効率的なコードになるとは限りませんが、一応、使えるものにはなると思います。
コツとしては、記録を取る際には「無駄な操作は全て省く」ことでしょうか。

No.3 回答者： Qchan1962 回答日時： 2020/04/28 01:47

こんばんは、

＞ただし、３つのシートの表は全く同じではなく店舗名の項目も同じ位置ではないです。
さすがにまだアバウトですね。同じでないなら、示さなければ中々アドバイスはできません。
＞マクロを作成したいのですが、教えていただけたら助かります。
ソースコードなどが示されていないのでどこからアドバイスすれば良いか分かりません。

手順でしょうか？
想像の範疇を超えませんが、あくまで一例として
①店舗項目の重複しないリストを作る。（配列など）＊Sheets(1)が良さそう？
②新規ブックを3シートで作成する
③店舗項目にリストでフィルタをかける　＊この場所が不明（補足にもない）
④対象シートの可視セルをコピー新規ブックの対象シートにペーストする
⑤シート数③④を繰り返す
⑥新規ブックにリスト名で保存し閉じる
⑦リストの数だけ②～⑥を繰り返す

参考コード書いたほうが良いか悩みましたが、一応　書いてみました。うまく完了すれば良いのですが、、
解らないかも知れませんが、内容を必ず確認してコピーファイルなどで試してください。

仕様は下記条件
＞シートが３つあります。　
＊3シートの新規ブックを作成します

＞～商店で絞りファイル名はA商店として保存します。
キーワードをファイル名にします。＊ただしすでに同名ファイルがある時の処理は割愛（ご自身で）

＞同じではなく店舗名の項目も同じ位置ではないです
画像だと店舗、ご質問だと店舗名、、、果たしてどちらか？　＊店舗とします。（各シートにこの見出しが必ずある事）

＞商店ごとのファイルを作成させたい
作成してデスクトップにキーワードで保存します。

＞A商店からF商店まであったとしたら６つのファイルを作成
キーワードの数は制限なし　＊ただし、メモリースタックの可能性はあります。

＊処理は比較的重いと思います。

Sub ANS()
Dim Rng
Dim i As Long, j As Integer: j = 0
Dim Key_list As New Collection, KeyItem()
Dim Temp As Integer
Dim thisBK As Workbook, WB As Workbook
　 　 Set thisBK = ThisWorkbook
　 　 With Application
　 　 　 　 .ScreenUpdating = False
　 　 　 　 .EnableEvents = False
　 　 　 　 .DisplayAlerts = False
　 　 　 　 .Calculation = xlCalculationManual
　 　 End With
　 　 On Error Resume Next
　 　 Rng = TargetRng(1)
　 　 With Sheets(1)
　 　 　 　 For i = 4 To .Cells(Rows.Count, Rng(2)).End(xlUp).Row
　 　 　 　 　 　 On Error Resume Next
　 　 　 　 　 　 Key_list.Add .Cells(i, Rng(2)).Value, CStr(.Cells(i, Rng(2)).Value)
　 　 　 　 　 　 If Err.Number = 0 Then
　 　 　 　 　 　 　 　 ReDim Preserve KeyItem(j)
　 　 　 　 　 　 　 　 KeyItem(j) = .Cells(i, Rng(2)).Value
　 　 　 　 　 　 　 　 j = j + 1
　 　 　 　 　 　 End If
　 　 　 　 　 　 On Error GoTo 0
　 　 　 　 Next
　 　 End With
　 　 Temp = Application.SheetsInNewWorkbook
　 　 For i = 0 To UBound(KeyItem)
　 　 　 　 Application.SheetsInNewWorkbook = 3
　 　 　 　 Set WB = Workbooks.Add
　 　 　 　 thisBK.Activate
　 　 　 　 For j = 1 To 3
　 　 　 　 　 　 Rng = TargetRng(j)
　 　 　 　 　 　 thisBK.Sheets(j).Range(Rng(0)).Offset(1).AutoFilter 1, KeyItem(i)
　 　 　 　 　 　 thisBK.Sheets(j).Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy WB.Sheets(j).Range("A1")
　 　 　 　 　 　 thisBK.Sheets(j).Cells.AutoFilter
　 　 　 　 Next
　 　 　 　 WB.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & KeyItem(i) & ".xlsx"
　 　 　 　 WB.Close
　 　 　 　 Set WB = Nothing
　 　 Next
　 　 Application.SheetsInNewWorkbook = Temp
　 　 With Application
　 　 　 　 .ScreenUpdating = True
　 　 　 　 .EnableEvents = True
　 　 　 　 .DisplayAlerts = True
　 　 　 　 .Calculation = xlCalculationAutomatic
　 　 End With
　 　 MsgBox ("完了")
End Sub
Function TargetRng(ShtIdx As Integer) As Variant
Dim K_Rng As Range, RngData(2)
Dim thisBK As Workbook
　 　 Set thisBK = ThisWorkbook
　 　 Set K_Rng = thisBK.Sheets(ShtIdx).Cells.Find(What:="店舗", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, MatchByte:=False)
　 　 RngData(0) = K_Rng.Address(0, 0)
　 　 RngData(1) = K_Rng.Row
　 　 RngData(2) = K_Rng.Column
　 　 TargetRng = RngData
　 　 Set thisBK = Nothing
　 　 Set K_Rng = Nothing
End Function

＊ネット上に挙がっているプログラムを分からず実行するのは危険です。
悪意あるソースコードもありますので、自己責任でお願いします。

No.4 回答者： Qchan1962 回答日時： 2020/04/28 01:50

投稿して気が付きましたが、

＞値にして
thisBK.Sheets(j).Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy WB.Sheets(j).Range("A1")
ここは、自身で直してください。