[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『別ブックの表の合計欄がゼロ以外の全ての値を抽出』（333）
BOOK1に商品名などが入力されている表があります。
A列に商品名 B～H列に数を入力 I列に合計
１列めは全て項目名
２列めから上記の物を入力しております。
BOOK1を毎月名前を付けて保存で同じファイル内に
2015年1月
2015年2月
2015年3月
とどんどん作っていきます。
そして集計用BOOKのsheet2に
月ごとに合計欄が0以外の商品の商品名と合計数を抽出し、毎月sheet2に抽出結果が
溜まっていくような表をつくりたいのです。
手作業を考えましたが毎月の商品名がかなりの量なので
簡単に抽出できないかと思い調べましたがなかなか理想のものを探すことができず
質問させて頂きました。
BOOK1のファイルを毎月名前を付けて保存で増やしていくので
マクロボタンなどを集計用BOOKのsheet2上に表示させ
そのボタンを押すことでファイル名(日付で）を指定したりして
なんとか商品名と数量合計欄を抽出したいです。
集計用BOOKのsheet2は
A列商品名 B列作業用 C列数量
このようなレイアウトになっております。
どなたかわかる方よろしくお願い致します。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
>BOOK1を毎月名前を付けて保存で同じファイル内に
同じファイル内？？ 同じフォルダ内 かな？
（β） 2015/03/13(金) 13:56
今、出先で、コードがかけないんですが、以下のような流れでいけると思います。
マクロブックに作業シート（隠しシートでもOK）を作っておき その A1 に、集計用BOOKの該当シートののA1、商品名のタイトルと同じものをセット。 その B1 に、同じく集計用BOOKの該当シートの I1、合計のタイトルと同じものをセット。 その D1 にも 合計のタイトルと同じものをセット。 その D2 に <>0 といれておく。
ここまでが準備作業 で、コードは
GetOpenFileName 等のファイル選択ダイアログを表示して、ブックを選択させる。 そのブックを開く そのブックの当該シートのデータ域を指定したフィルターオプション 条件欄が作業シートの D1:D2 別の場所に抽出。その抽出先が作業シートのA1:B1 作業シートに抽出されたもののタイトル行を除き、集計BOOKのSHeet2の最後の行の１つ下の A列に作業シートの A1:A○、 C列に作業シートの B1:B○ をコピペ。 そのブックを閉じる
一度、上記の手順で操作して、それをマクロ記録とれば、ほとんどの部分のコードが生成されるので あとは、それをブラッシュアップしてらいいかと。
（β） 2015/03/13(金) 14:39
ファイルはダイアログから操作者に選んでもらう流れなので、ファイルが何千個できてもＯＫですよ。 ボタンを押すだけで、操作者が思っているファイルをマクロが自動で選別するなんてことは、超能力者じゃないと無理だけど。
もちろん「上記作業をやって」それを「マクロ記録して」、できあがったコードを「ブラッシュアップして」 それをボタンに割り当てるんですよ。
（β） 2015/03/13(金) 20:02
提示の流れで
GetOpenFileName 等のファイル選択ダイアログを表示して、ブックを選択させる。
これはマクロ記録できませんので、その部分のみ、以下の Test1 として。 また、別の方法として操作者に、年月を指定させる方法もあります。これが Test2。 こちらでは、 2015/3 とか 2015年3月 といった指定ができます。
Sub Test1()
'フォルダからブックを選択させる場合
Dim fName As Variant
fName = Application.GetOpenFilename("ExcelBook,*.xls*", , "処理するブックの選択")
If fName = False Then Exit Sub 'キャンセルボタン
'★ ブックを開き、処理をして保存して閉じるコードをここに。
'★ 開くべきブックは fName
End Sub
Sub Test2()
'年月を指定させて処理する場合
Dim myPath As String
Dim ymd As Long
Dim fName As String
Dim ck As String
'C:\Users\xxxxxx\Test\ の場合
myPath = Environ("USERPROFILE") & "\Test\"
'DeskTop の中のフォルダなら
' myPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\Test\"
'ドキュメント の中のフォルダなら
' myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\Test\"
ymd = Application.InputBox("対象年月を入力してください", Type:=1)
fName = Format(ymd, "yyyy年mm月") & ".xlsx"
'ブックの存在チェック"
ck = Dir(myPath & fName)
If ck = "" Then
MsgBox fName & " が存在しません"
Exit Sub
End If
'★ ブックを開き、処理をして保存して閉じるコードをここに。
'★ 開くべきブックは myPath & fName
End Sub
（β） 2015/03/14(土) 09:04
フォーマットも、そうですが、
>うまく商品名と数量のみを抽出できずに困っております
といわれても、それはコードが悪いからでしょう、あるいは操作手順が間違っていたからでしょうとしかコメントできません。 どんなコードで実行しているのか、あるいは、操作であれば、どんな値をどこに与えながら操作したのかがわかりませんので。
そちらのコードをアップ、あるいは、そちらの操作を逐一、説明してください。
（β） 2015/03/17(火) 11:42
追加で
抽出元のブック群ですが、
A～I と J～R、ブロックが２つありますが、抽出したいのはどちらですか、あるいは両方、あるいは両方の合算？
で、この２つのブロックのタイトルですが、同じですか？異なっていますか？ たとえば B1 は商品1、K1 は商品2 とか？ それとも、どちらも同じ？
それと
>うまく商品名と数量のみを抽出できずに困っております。
どう、うまくいかないのか、エラーになるのか、思ったような結果にならないのか、そのあたりも 具体的に（エラーなら、どんな操作をしたときにどんなエラーになったのか、思ったようなけっかにならないなら こんな結果になってほしかったのに、こうなってしまった）説明してくださいね。
（β） 2015/03/17(火) 11:56
マクロはうまくいかなかったので削除してしまいましたが
手順としては標準作業をし、集計用ブックにsheet1の作業用シートを設け
マクロの記録ボタン実行後、抽出用ブックを開き抽出用シート1をフィルターオプション
集計用ブックsheet1に抽出できずに止まってしまいました。
（333） 2015/03/17(火) 12:05
レイアウトが変更（しかも対象の場所が２か所）になったんだから、アップした操作手順も、それなりに調整しないと いけないんだけど、それを、やりとりしていると、それだけで、何日もかかりそうなので、コード案をアップします。 もし、具合悪ければ、レイアウトに関する誤解があるということなので、指摘願います。
事前準備（ちょっと変更しています）
１．マクロブックに"条件"という名前の作業シート（隠しシートでもOK）を作成。 ２．その A1 に、集計用BOOKの該当シートのB1,K1商品名のタイトルと同じものをセット。 ３．その B1 に、集計用BOOKの該当シートのA1,J1作業列のタイトルと同じものをセット。 ４．その C1 に、集計用BOOKの該当シートのI1,R1合計列のタイトルと同じものをセット。 ５．その E1 にも 合計のタイトルと同じものをセット。 ６．その E2 に <>0 といれておく。
これは一度やっておけば、それでＯＫ。 なお、抽出元ブックの中の抽出シートは、そのブックの最初のシートにしている。 また、このシートにシート保護はかかっていないという前提です。
で、コード。
Sub Test()
Dim shF As Worksheet
Dim shT As Worksheet
Dim shW As Worksheet
Dim fName As Variant
Dim col As Variant
Dim pos As Range
fName = Application.GetOpenFilename("ExcelBook,*.xls*", , "処理するブックの選択")
If fName = False Then Exit Sub 'キャンセルボタン
Set shT = ThisWorkbook.Sheets("Sheet2") '集計用シート
Set shW = Sheets("条件") '条件指定の作業用隠しシート
Set shF = Workbooks.Open(fName).Sheets(1) '★選んだブックの最初のシートを抽出シートとする
For Each col In Array(shF.Range("A1").CurrentRegion.Columns("A:I"), shF.Range("A1").CurrentRegion.Columns("J:R"))
'合計欄 0 以外を抽出
col.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=shW.Range("E1:E2"), CopyToRange:=shW.Range("A1:C1"), Unique:=False
'転記
With shW.Range("A1").CurrentRegion
If .Rows.Count > 1 Then '抽出あり？
With shT.Range("A1").CurrentRegion
Set pos = shT.Range("A" & .Rows.Count + 1).Resize(, 3)
End With
pos.Resize(.Rows.Count - 1).Value = .Cells.Offset(1).Resize(.Rows.Count - 1).Value
End If
End With
Next
'抽出元ブックを閉じる
shF.Parent.Close False
End Sub
（β） 2015/03/17(火) 15:56
>もしも抽出用シートが増えた場合などはどのように対応すれば良いか教えていただけますか？
対象のシート名が、これとこれ といったように特定できるなら、ほんのちょっとの改造でいけますが？
（β） 2015/03/17(火) 16:51
col.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=shW.Range("E1:E2"), CopyToRange:=shW.Range("A1:C1"), Unique:=False
ここの部分で止まってしまいました。
抽出先ブックの抽出シートのフォーマットは
商品名 作業列 数量になっております。
条件というシートを作って試しました。
（333） 2015/03/18(水) 10:44
とまったときにでたメッセージはどういうものでしたか？ メッセージの内容を教えてください。（正確に）
おそらく、「フィールド名がどうこう」というもの？ フィルターオプション処理でありがちな間違いにより、よくでるメッセージです。
条件シートの A1:C1 の３つのセルに、各抽出元から抜き出すべき項目名をいれるわけですが この３つの項目を抽出元から抜き出そうとしたときに、抽出元に、そのタイトルと全く同じものがないと 抽出できず、このエラーになります。
すべての抽出元のブックの最初のシートの１行目のタイトル、全く同じものになっていますか？
たとえば 条件シート側には "商品名" でも、抽出元側には ２つのブロックの１つでも、"商品 名" になっているとエラーです。
（β） 2015/03/18(水) 11:15
抽出元シート
商品名 作業列 数量
条件シート
A商品名 B作業 C合計 D空白 E合計
<>0
抽出先シート1
A作業列 B商品名 C～H数量入力項目 I合計 J～RもA～I同様
抽出先シート２も同じフォーマット
抽出先シート３～５
A3：N4商品（○○）○○の部分は３～５とも内容が違います。
A5:D5 商品別の項目（缶詰、汁物類、など）
この項目はセルの途中でも存在しこの項目の下に抽出したい商品名があります。
E~Gまでは数量を入力する項目になってます。
H～Nも上記と同じように項目が入っていて一つの表になってます。
ここにはGの後Nの後に合計欄を加えるつもりです。
ただ商品名とかなどの決まった項目ではなく商品の種類別項目になってるので
こちらは難しいのかなと半ば諦めております。
（333） 2015/03/18(水) 14:57
１４：５７ アップの説明は、今から読みますが、ＱＡ掲示板でよくあるケースにはまりこんでいますね。 こちらではテスト環境をつくってコードを試して結果ＯＫだと思っている、だけど質問側は、できません、あるいはエラーです。
ＱＡ掲示板の宿命ですね。質問の意図を誤解している、そのレイアウトを誤解している、一方で質問側も 回答側のコメントを誤解している、あるいはよくわからないまま、とにかく動かして、思うようにならない・・
これは避けることができない壁で、でも、乗り越えなきゃいけない。 のりこえるためには、双方、「努力」と「協力」が必要ですね。
たとえば、（β） 2015/03/18(水) 11:15 でメッセージを【正確に】教えてほしいと依頼、だけど回答は 「そのメッセージでした」 エラーメッセージにはエラー番号とメッセージ文言があって、エラー番号が同じでもメッセージ文言が異なる場合もあるし メッセージ文言が【よく似ていても】エラー番号によって、意味が異なるものが少なくないです。
まぁ、今回のフィルターオプションの場合のメッセージは、これでよしとしましょう。
>何度か試してみて一応抽出ができました。
これは、ありえません。同じコードで同じデータを扱えば、それがエラーになるなら、何百回やってもエラーになります。 エラーなしで進んだということは、 ・コードを直した ・データを直した ・設定（条件シート）を直した いずれかです。どう直したのかを具体的に連絡もらえれば、あぁ、そうか、こちらの勘違いだ、コードも直そうといった アクションもとれます。何を直したのかわからない状態で、前はエラーだったけど、今は大丈夫といわれても じゃぁ、コードはこのままでいいのかどうか？ 悩みますよ。
●何をどう直して、処理が進んだのかを具体的に教えてください。
次に、「ですがＪ～Ｒまでの値のみ抽出との結果になりました。 」
これは、集計用シートの結果ですか？ 条件シートの結果ではないですか？ 条件シートは、条件記述の他に作業用に使っています。 目的のブックの A:Iのみを抽出して、集計用シートに【追加】 次に、J:R【のみを】抽出し、それを集計用シートに【追加】 なので、処理後の条件シートには、J:R【のみが】残っています。
追加で。
まだ、レイアウト説明はすべて読んでいませんが読みかけたところで、あれ？と。 まぁ、最終的には、そちらの実際のブック構成に合わせますが、現状では、
マクロブック
"条件" シート いろんな条件を設定。かつ、選んだ抽出元ブックからの抽出をいったん、このシートで受ける。 "Sheet2" 集計用シート。抽出されたデータを最終的に、ここに【追加】してため込んでいく。
選んだ抽出元ブック
コード内で
Set shF = Workbooks.Open(fName).Sheets(1) '★選んだブックの最初のシートを抽出シートとする
と、コメントつけて説明しているつもりだったけど、抽出してくるシートは【１つだけ】 そのブックの最初のシート。 もし、そうじゃないなら、そうじゃない、２つ目のシートもありますと、そうレスしてほしい。
アップされた説明を見ると、抽出シート１，２，が同じフォーマトと書いてある。 これは初めて説明をうけるんだけど、２つのシートなの？ ３，４，５については、今後増えたらどうするかとの追加質問の件だと理解。それはそれで一段落したら対応予定。 だけど、現在は、あくまで抽出元シートは１枚でいいんだよね？
（β） 2015/03/18(水) 16:14
最終的にはおっしゃる通りで集計シートにため込んでいく形にしたいです。
抽出元シートは
抽出シート1と2があり同じフォーマットになっています。
すみません、説明不足でした。
なので合計で5シートを抽出したい形に現在なっております。
（333） 2015/03/18(水) 18:24
いや、そういうことを聞いているのではなく、（β） 2015/03/17(火) 15:56 の現在のコードで 選んだブックの A:I、J:R の対象のものが、ちゃんと マクロブックの集計用シートにため込まれていますか？ それとも、結果は、そうなっていないのですか？
そういうことを聞いています。
条件シートに存在するデータは、↑で説明した通りの作業用データです。 あくまで、集計用シートはどうなりましたかと聞いています。
それと、現行のコードは抽出シート２は相手にしていませんので、それを対応するなら、今の課題がクリアになってからですね。
（β） 2015/03/18(水) 19:03
追加で
●何をどう直して、処理が進んだのかを具体的に教えてください。
こう、お願いしています。 回答をお願いしますね。
（β） 2015/03/18(水) 20:41
●何をどう直して、処理が進んだのかを具体的に教えてください。
これについてはいかがですか。
（β） 2015/03/18(水) 21:50
レスありがとうございます。
以下、協力いただけませんか。
１．新規ブックの標準モジュールに以下のマクロ MakeDataをコピペして実行してください。 ２．出来上がったブックを任意のフォルダに任意の名前を付けて保存して閉じてください。 マクロがあるのでメッセージが出ますので、はい を押してマクロなしの xlsx にしてください。
Sub MakeData()
Dim sh As Worksheet
Dim i As Long
Set sh = ThisWorkbook.Sheets(1)
sh.Cells.Clear
sh.Range("A1:I1").Value = Array("作業列", "商品名", "数量1", "数量2", "数量3", "数量4", "数量5", "数量6", "合計")
sh.Range("J1:R1").Value = Array("作業列", "商品名", "数量1", "数量2", "数量3", "数量4", "数量5", "数量6", "合計")
For i = 2 To 21
sh.Cells(i, 1).Value = "作業1" & i
sh.Cells(i, 2).Value = "商品1" & i
If i Mod 2 = 0 Then
sh.Cells(i, 3).Resize(, 7).Value = 0
Else
sh.Cells(i, 3).Resize(, 7).Value = 10
End If
Next
For i = 2 To 11
sh.Cells(i, 1 + 9).Value = "作業2" & i
sh.Cells(i, 2 + 9).Value = "商品2" & i
If i Mod 2 <> 0 Then
sh.Cells(i, 3 + 9).Resize(, 7).Value = 0
Else
sh.Cells(i, 3 + 9).Resize(, 7).Value = 20
End If
Next
End Sub
３．もう１つ新規ブックを立ち上げて、その標準モジュールに以下のマクロをコピペ。
Sub Prepare()
Dim sh2 As Worksheet
On Error Resume Next
Set sh2 = Sheets("Sheet2")
On Error GoTo 0
If sh2 Is Nothing Then
Worksheets.Add Before:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sheet2"
End If
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "条件"
With Sheets("条件")
.Range("A1:C1").Value = Array("商品名", "作業列", "合計")
.Range("E1").Value = "合計"
.Range("E2").Value = "<>0"
End With
With Sheets("Sheet2")
.Cells.Clear
.Range("A1:C1").Value = Array("商品", "作業列", "合計")
End With
End Sub
Sub Test2()
Dim shF As Worksheet
Dim shT As Worksheet
Dim shW As Worksheet
Dim fName As Variant
Dim col As Variant
Dim pos As Range
fName = Application.GetOpenFilename("ExcelBook,*.xls*", , "処理するブックの選択")
If fName = False Then Exit Sub 'キャンセルボタン
Set shT = ThisWorkbook.Sheets("Sheet2") '集計用シート
Set shW = ThisWorkbook.Sheets("条件") '条件指定の作業用隠しシート
Set shF = Workbooks.Open(fName).Sheets(1) '★選んだブックの最初のシートを抽出シートとする
For Each col In Array(shF.Range("A1").CurrentRegion.Columns("A:I"), shF.Range("A1").CurrentRegion.Columns("J:R"))
'合計欄 0 以外を抽出
col.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=shW.Range("E1:E2"), CopyToRange:=shW.Range("A1:C1"), Unique:=False
'転記
With shW.Range("A1").CurrentRegion
If .Rows.Count > 1 Then '抽出あり？
With shT.Range("A1").CurrentRegion
Set pos = shT.Range("A" & .Rows.Count + 1).Resize(, 3)
End With
pos.Resize(.Rows.Count - 1).Value = .Cells.Offset(1).Resize(.Rows.Count - 1).Value
End If
End With
Next
'抽出元ブックを閉じる
shF.Parent.Close False
'集計用シート表示
shT.Select
End Sub
４．Prepare を実行してください。
５．Test2 を実行してください。
ブックの選択画面で、２．で保存したブックを選んでください。
結果はどうなるでしょうか。連絡いただけますか？
（β） 2015/03/19(木) 07:56
条件sheet
商品名 作業列 合計 合計
商品22 作業22 20 <>0
商品24 作業24 20
商品26 作業26 20
商品28 作業28 20
商品210 作業210 20
sheet2
商品 作業列 合計
商品13 作業13 10
商品15 作業15 10
商品17 作業17 10
商品19 作業19 10
商品111 作業111 10
商品113 作業113 10
商品115 作業115 10
商品117 作業117 10
商品119 作業119 10
商品121 作業121 10
商品22 作業22 20
商品24 作業24 20
商品26 作業26 20
商品28 作業28 20
商品210 作業210 20
の結果になりました。
sheet1,3にはなにもアクションはなかったです。
（333） 2015/03/19(木) 09:54
これでいいんですよね？
最終目的は集計用シートでのためこみ。で、今回実行してもらったコードでは、それをSheet2にしていますので。
選んだブックの A:I と J:R の数量合計がゼロではないものがすべて、集計用シートに反映していますよね？
Sheet1やSheet3は、もともと、相手にしていませんので。
（β） 2015/03/19(木) 11:18
よかったです。
今、そちらで動かしているコード、そのままコピペでアップいただけませんか。 Sheet2の罫線などの書式対応や、今後の抽出元ブックのシートが１枚じゃなく２枚の対応も 加味してみます。
そのあとの、複雑なシート３，４，５ といったものも、シートのレイアウト基準（レイアウトルール）が わかれば（フィルーターオプションは難しいかもしれませんが）対応を考えることはできると思います。
（β） 2015/03/19(木) 12:59
第一報。
Sheet2(集計用シート）の罫線等はいっさい変更されないはずですよ。 Sheet2へは、値のみを転記していますので。
もしかして、罫線などがあったのは、抽出元ブックのほうですか？ もし、そうなら、う～ん・・・・ せっかくのフィルターオプションがつかえないかも。
追記 17:42
あっ！もしかして （β） 2015/03/19(木) 07:56 で作ったマクロブックのSheet2のことをいってますか？ もし、そうなら、これは、仮のテストマクロブックですから、本番のマクロブックのマクロを Test2 でいれかえてもらえばいいのですが？
もちろん、今回作った新しいマクロブックを正として運用していくなら、今回のブックのSheet2に あらためて罫線などをつけてもらう必要はありますが？
（β） 2015/03/19(木) 17:41
実際の実行コード（TestやTest2)では罫線他書式は一切触っていませんし、こちらでSheet2に罫線をセットして Test2を実行させても、罫線は消えません。
テスト用環境を作成してもらうためにアップした Prepareでは、確かに罫線があればクリアしていますが これは、
> ３．もう１つ新規ブックを立ち上げて、その標準モジュールに以下のマクロをコピペ。
こうコメントした通り、テスト環境としての実行マクロを含んだブックを作成してもらうためです。 これを、本番ブックに組み込んで、動かしたのでしょうか？
このPrepareは テスト環境作成用ですから、本番では動かしません。
で、もう１つの Test2 は、今までの Test と基本的にはかわりません。 （シート修飾で気になるところがあったので１か所変更したのと、処理後に Sheet2を表示させるコードを追加しただけ）
なので、本番ブックの Test を、今回の Test2 で置き換えていただくことはＯＫですが、本番処理に Prepare は全く必要ありませんので。
●今回、確認したかったことは、Test も Test2 も処理ロジックはかえておらず、つまり、 「今までも、実は Sheet2 にあたるブックにため込まれていたんでしょ？だから、今までもＯＫだったんでしょ？」 ということなんですが。
●さて、処理自体はＯＫになったと思います。 この先、選択した抽出元ブックに抽出すべきシートが２枚あった時の対応をやりましょうか？ それとも、本トピは、解決ということで閉じられますか？
（β） 2015/03/20(金) 10:36
罫線の件はＯＫということでいいですね？
まず、選択したブックの最初の２枚のシートに決め打ちして抽出するパターンです。 かりに、そのブックのシートが１枚しかなくてもＯＫにしています。
Sub Test3()
Dim bkF As Workbook
Dim shF As Worksheet
Dim shT As Worksheet
Dim shW As Worksheet
Dim fName As Variant
Dim col As Variant
Dim pos As Range
Dim x As Long
fName = Application.GetOpenFilename("ExcelBook,*.xls*", , "処理するブックの選択")
If fName = False Then Exit Sub 'キャンセルボタン
Set shT = ThisWorkbook.Sheets("Sheet2") '集計用シート
Set shW = ThisWorkbook.Sheets("条件") '条件指定の作業用隠しシート
Set bkF = Workbooks.Open(fName) '選んだブック
For Each shF In bkF.Worksheets '選んだブックからシートを取り出す
x = x + 1
If x > 2 Then Exit For
For Each col In Array(shF.Range("A1").CurrentRegion.Columns("A:I"), shF.Range("A1").CurrentRegion.Columns("J:R"))
'合計欄 0 以外を抽出
col.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=shW.Range("E1:E2"), CopyToRange:=shW.Range("A1:C1"), Unique:=False
'転記
With shW.Range("A1").CurrentRegion
If .Rows.Count > 1 Then '抽出あり？
With shT.Range("A1").CurrentRegion
Set pos = shT.Range("A" & .Rows.Count + 1).Resize(, 3)
End With
pos.Resize(.Rows.Count - 1).Value = .Cells.Offset(1).Resize(.Rows.Count - 1).Value
End If
End With
Next
Next
'抽出元ブックを閉じる
bkF.Close False
'集計用シート表示
shT.Select
End Sub
（β） 2015/03/20(金) 11:23
こちらは、選んだ抽出元ブックの中から抽出すべきシート名が決まっているというケースです。 コード内のシート名を実際のものにかえて試してみてください。
なお、先にアップした、先頭のシートから枚数指定で抜き出すものも、今アップするものも、コードとしては ２枚のシートを相手にしていますが、いずれも、「シートレイアウトが同じなら」何枚でも対象に増やしていくことは わずかなコードの変更で可能です。
●Test3,Test4が一段落したら、次の レイアウトが異なるシートの対応にすすみますかね？
Sub Test4()
Dim bkF As Workbook
Dim shF As Worksheet
Dim shT As Worksheet
Dim shW As Worksheet
Dim fName As Variant
Dim col As Variant
Dim pos As Range
fName = Application.GetOpenFilename("ExcelBook,*.xls*", , "処理するブックの選択")
If fName = False Then Exit Sub 'キャンセルボタン
Set shT = ThisWorkbook.Sheets("Sheet2") '集計用シート
Set shW = ThisWorkbook.Sheets("条件") '条件指定の作業用隠しシート
Set bkF = Workbooks.Open(fName) '選んだブック
For Each shF In bkF.Worksheets '選んだブックからシートを取り出す
Select Case shF.Name
Case "抽出1", "抽出2" '対象シート名 実際のものに
For Each col In Array(shF.Range("A1").CurrentRegion.Columns("A:I"), shF.Range("A1").CurrentRegion.Columns("J:R"))
'合計欄 0 以外を抽出
col.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=shW.Range("E1:E2"), CopyToRange:=shW.Range("A1:C1"), Unique:=False
'転記
With shW.Range("A1").CurrentRegion
If .Rows.Count > 1 Then '抽出あり？
With shT.Range("A1").CurrentRegion
Set pos = shT.Range("A" & .Rows.Count + 1).Resize(, 3)
End With
pos.Resize(.Rows.Count - 1).Value = .Cells.Offset(1).Resize(.Rows.Count - 1).Value
End If
End With
Next
End Select
Next
'抽出元ブックを閉じる
bkF.Close False
'集計用シート表示
shT.Select
End Sub
（β） 2015/03/20(金) 11:30
CriteriaRange:=shW.Range("E1:E2"), CopyToRange:=shW.Range("A1:C1"), Unique:=False
の部分ででてしまいました。
Test4は
抽出1の部分はうまく反映されるのですが
2のほうは反映されていません。
（333） 2015/03/20(金) 13:09
まず、従来のコードと今回の Test3,4は基本的に同じです。 元ブックから取り込むシートを増やしているだけです。
ですから、Test3 のエラーは、選択したブックの1枚目のシートはOKだったのでしょうから、2枚目のシートのタイトルに 商品名 作業列 合計 のいずれかがないという現象です。シートを調べてみてください。 (このあたりは、今までの取り組みで十分にわかっているところだと思います。まずタイトルが一致しているかどうか それを調べて、その状態もあわせて報告してくださいね）
Test4 のほうは、抽出１であろうが、抽出２であろうが、コードロジックは同じです。 ですから、抽出2 という、コードで相手にしているシートがない（全角、半角も一致している必要があります） あるいは、その名前のシートはあるけど、対象（合計がゼロではないもの）がないか、どちらかでは？
（β） 2015/03/20(金) 13:21
（333） 2015/03/20(金) 14:40
以前もそうでしたけど、
>Test3では抽出した範囲にはフィールド名がないか、または無効なフィールド名です。
でも、
>test3うまく実行できましたが
エラーになるなら何度やってもエラーです。 何か直したんですよね？ それを、ここが、こうなっていたので直したらOKになったと報告いただかないと 「たまたまOKだったのかな？ロジックのチョンボは、まだなおっていないのかな？調べよう」と、こちらは、そういうことを 続けなきゃいけません。
●どこをどうしたか（どこが、どうなっていたか）を教えてください。 （うまくいったんだから、もういいじゃないか ということではなく、重要なことですから）
いずれにしてもそちらでは Test3もTest4も1枚目のシートしか処理されなかったということですね？ ほんとですか？ Sheet2に、ほんとに溜め込まれていませんか？
いままでも、Sheet2にためこまれていたのに、ずっと（なぜか）ためこまれていない、不具合だと そういってきましたよね？まぁ、疑うわけではありませんが、そちらの勘違いということもあるので。
一度、Sheet2をクリアしてから実行するとわかりやすいかもしれませんよ。
（β） 2015/03/20(金) 15:00
クリアして試しましたがどちらもｓｈｅｅｔ1のみの抽出になりました。
（333） 2015/03/23(月) 09:59
>全てをイコールをつかって値をあわせ実行したら成功しました。
ということは、マクロコードの問題ではなく、抽出しようとしているブックのシートのタイトルが 指定の文字列ではなかったということですね？
フィルターオプション処理をすると、必ずといっていいほど、この件で、Ｑ／Ａのやりとりをしなきゃいけないので 実行前に、タイトルの整合性がとれているかどうかをチェックして、不整合なら、メッセージを出して 終了させる構えにしたほうが（回答側にとって）労力のせつやくになるのかな？ と、最近、思い始めています。
>ｓｈｅｅｔ1のみの抽出になりました。
（β） 2015/03/19(木) 07:56 で提示した、２．の部分、テストブック作成マクロ、MakeData で新規ブックを作成し それにSheet2があれば、Sheet1 のセルをすべてコピペでSheet2 に転記、Sheet2がなければ、シート挿入で Sheet2を作成した上で、Sheet1の内容をSheet2にコピペ。 これを任意の名前で保存した上で、Test3 を実行してみてください。
元ブックのSheet1もSheet2も同じ内容なので見づらいかもしれませんが、うまくいけば、マクロブックの Sheet2 には、Sheet1からだけの抽出の２倍のデータがあるはずです。
確認お願いします。
（β） 2015/03/23(月) 17:30
こんな感じの結果になりました。
（333） 2015/03/24(火) 09:40
不思議ですねぇ。 実行は （β） 2015/03/20(金) 11:23 の Test3 でやりましたか？ （β） 2015/03/19(木) 07:56 の Test2 であれば、報告された結果になりますが Test3 でやれば、こちらでは
商品13 作業13 10
商品15 作業15 10
商品17 作業17 10
商品19 作業19 10
商品111 作業111 10
商品113 作業113 10
商品115 作業115 10
商品117 作業117 10
商品119 作業119 10
商品121 作業121 10
商品22 作業22 20
商品24 作業24 20
商品26 作業26 20
商品28 作業28 20
商品210 作業210 20
商品13 作業13 10
商品15 作業15 10
商品17 作業17 10
商品19 作業19 10
商品111 作業111 10
商品113 作業113 10
商品115 作業115 10
商品117 作業117 10
商品119 作業119 10
商品121 作業121 10
商品22 作業22 20
商品24 作業24 20
商品26 作業26 20
商品28 作業28 20
商品210 作業210 20
になりますが？？？
（β） 2015/03/24(火) 10:13
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.