Excel 複数シートから複数条件を別シートに

Excel2007を使っています。

添付画像のように、A社、B社へ送った見積のうち、発注があったものだけを
別シートに月別一覧として表示させたいです。
A社、B社は別々のシートです。
初めのうちはシート毎にフィルタを使って抽出していたのですが、
データが大量にあるため、別シートで分かりやすく見れるようにしたいです。
また、当てはまる行のうち全ての項目を抽出するのではなく、添付画像のように指定した項目のみを表示させたいです。どなたか教えて下さい

No.5 ベストアンサー 回答者： KURUMITO 回答日時： 2013/06/15 09:46

条件が複雑で大分苦労しましたが関数で処理する方法です。

関数で処理することでシートの数が多くなっても即座に対応できますし（ここでの例では１０シートまで）、データがそれぞれのシートに新たに追加された場合でも即座にお求めの表が自動的に変更されますので、常に最新のデータがお求めの表に表示されていることになります。マクロでは操作を行わなければ最新のデータの表示とはなりませんね。また、お求めの表では２カ月間の表示とは限らずに、例ですが、６カ月間までを表示させることもできるようになっています。
なお、日付の入力は6/1や６月１日のように入力しても数式バー上では2013/6/1のように日付として認識されていることが必要です。また、まとめの表では6月のデータとするときには6/1や2013/6/1のように入力してからセルの表示形式のユーザー定義で m月　のようにして6月と表示させるようにします。
これから示す例ではまとめの表をシート幾つに作成してもよいのですがシート３にまとめの表を表示させるとします。
初めに各会社ごとのシート、シート１、シート２、シート４、シート５・・・について作業列をＧ列に設けます。各シートのＧ2セルには次の式を入力して下方にドラッグコピーします。作業に当たっては例えば6月と7月の表を作るとしたらシート3のA3セルに2013/6/1、A4セルには2013/7/1　のように入力しておくのがよいでしょう。入力が無い場合には空白のままのセルとなります。

=IF(D2="","",IF(COUNTIF(Sheet3!A$3:A$8,DATE(YEAR(D2),MONTH(D2),1))>0,DATE(YEAR(D2),MONTH(D2),1)*1000+COUNTIF(D$2:D2,">="&DATE(YEAR(D2),MONTH(D2),1))-COUNTIF(D$2:D2,">="&DATE(YEAR(D2),MONTH(D2)+1,1)),""))

そこでまとめのシートですが例えばシート3に作るとして次のようにします。
Ｂ1セルから横方向には会社名をＡ社、Ｂ社、Ｃ社・・・のようにＫ1セルまでに入力します。
Ｂ2セルから横のセルには対応するシート名を入力します。例えばB2セルにSheet1、Ｃ2セルにSheet2、Ｄ2セルにSheet4などと半角英数文字で実際のシート名に合う文字で入力します。
A3セルからA8セルまでには表示させたい月を6月と7月の表を作りたい場合にはA3セルには2013/6/1、A4セルには2013/7/1のように必ず月の初めの日付で入力します。その後にA3セルからA8セルを選択してセルの表示形式の「ユーザー定義」で m月　のようにして6月、7月のように表示させます。
B3セルには次の式を入力して右横方向のK3セルまでドラッグコピーしたのちに下方の8行目までドラッグコピーします。

=IF(OR($A3="",B$2=""),"",IF(ROW(A1)=1,IF(COLUMN(A1)=1,0,OFFSET(B3,0,-1)),IF(ROW(A1)>1,IF(COLUMN(A1)=1,MAX($B2:$K2),OFFSET(B3,0,-1))))+COUNTIF(INDIRECT(B$2&"!G:G"),">="&$A3*1000)-IF($A4="",0,COUNTIF(INDIRECT(B$2&"!G:G"),">="&$A4*1000)))

お求めの表は10行目から下方に表示させることにします。
A10セルには発注一覧表と入力します。
B11セルには得意先、C11セルには発注No、D11セルには商品名、E11セルには納品日とそれぞれ文字列を入力します。
A12セルには次の式を入力して下方にドラッグコピーします。

=IF(ROW(A1)=1,A3,IF(COUNTIF(INDEX(B$3:K$8,1,COUNT(B$3:K$3)):INDEX(B$3:K$8,6,COUNT(B$3:K$3)),ROW(A1)-1)=0,"",IF(INDEX(A$3:A$8,MATCH(ROW(A1)-1,INDEX(B$3:K$8,1,COUNT(B$3:K$3)):INDEX(B$3:K$8,6,COUNT(B$3:K$3)),0)+1)=0,"",INDEX(A$3:A$8,MATCH(ROW(A1)-1,INDEX(B$3:K$8,1,COUNT(B$3:K$3)):INDEX(B$3:K$8,6,COUNT(B$3:K$3)),0)+1))))

数値が表示されますがシリアル値が表示されますので、それらのセル範囲についてはセルの表示形式から日付を選んで好みの日付表示にします。
次のB12セルには次の式を入力して下方jにドラッグコピーします。

=IF(ROW(A1)>MAX($B$3:$K$8),"",IF(MIN(INDEX($B$3:$K$8,MATCH(LOOKUP(10^10,$A$12:$A12),$A$3:$A$8,0),1):INDEX($B$3:$K$8,MATCH(LOOKUP(10^10,$A$12:$A12),$A$3:$A$8,0),10))>=ROW(A1), $B$1,INDEX($B$1:$K$1,MATCH(ROW(A1)-0.1,INDEX($B$3:$K$8,MATCH(LOOKUP(10^10,$A$12:$A12),$A$3:$A$8,0),1):INDEX($B$3:$K$8,MATCH(LOOKUP(10^10,$A$12:$A12),$A$3:$A$8,0),10),1)+1)))

会社名が表示されます。
C12セルには次の式を入力してE12セルまで横にドラッグコピーしたのちに下方にもドラッグコピーします。

=IF($B12="","",INDEX(INDIRECT(INDEX($B$2:$K$2,MATCH($B12,$B$1:$K$1,0))&"!A:E"),MATCH(LOOKUP(10^10,$A$12:$A12)*1000+COUNTIF(INDEX($B$12:$B12,MATCH(10^10,$A$12:$A12)):$B12,$B12),INDIRECT(INDEX($B$2:$K$2,MATCH($B12,$B$1:$K$1,0))&"!G:G"),0),IF(COLUMN(A1)<=2,COLUMN(A1),IF(COLUMN(A1)=3,5))))

納品日の列にはシリアル値が表示されますのでそれらの範囲を選択してからセルの表示形式で日付から好みの日付表示に変更します。
以上で作業は終了です。式が複雑で理解するのが容易ではないと思いますが、お示しした通りでここに示した式をそのままコピーして一度試験してみてください。

この回答へのお礼

KURUMITO様

お礼が遅くなりました。
記載するのを忘れていたのですが、マクロについてほとんど知識がない為、関数でどうにかできないものかと考えておりました。
理解するのにだいぶ時間がかかってしまいましたが、お知恵を拝借しなんとか処理することが出来ました。
質問してよかったです。

他の回答者様も、ありがとうございました。

お礼日時：2013/06/18 16:43

No.4 回答者： MarcoRossiItaly 回答日時： 2013/06/15 00:26

皆さんが回答されているとおりマクロで処理すればご要望の表を作ることは可能と思いますが、今後のことを考えると、Sheet1 と Sheet2 を合わせて 1 つの表にしておくことをお勧めします。

具体的には、Sheet1 の左端あたりに 2 列を挿入。空白になっている B1 セルに「A 社」と記入。ダブルクリックにより下方向にオートフィル。念のため、A 列の各行には、1 などから始まる通し番号あるいはそれに類するものを振る。Sheet2 も同じ位置に「B 社」と通し番号を記入。Sheet2 には 1,000 行データが存在するとして、Sheet2 の A1:G1000 のセル範囲をコピーし、Sheet1 の最下行の次の行に貼り付け。最後に、Sheet2 を削除。これだけです。

これにより、Sheet1 にフィルタを取り付ければ日付ほかの項目で絞り込みができるし、ピボットテーブルも使えます。今回ご質問の表も、パッと作れるということになります。行の並べ替えも自由にできるし、通し番号を使えばいつでも元どおりの順序に戻せます。

No.3 回答者： optimumsoup 回答日時： 2013/06/15 00:01

頭の体操のつもりで、考えている間に、すでに回答されていますが、答えさせていただいていいでしょうか。

作業はシート4でやることと、項目が絞込みをしていない点が課題から外れていますが、目的は達されていると思います。
Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2013/6/14 ユーザー名 :
'

'
Dim sht1gyosu As Integer, sht2gyosu As Integer, sht4gyotop As Integer, sht4gyoend As Integer
Sheets("Sheet1").Select
sht1gyosu = Cells(Rows.Count, 1).End(xlUp).Row
'MsgBox sht1gyosu
Range(Cells(1, 1), Cells(sht1gyosu, 5)).Select
Selection.Copy
Sheets("Sheet4").Select
Range("A1").Select
ActiveSheet.Paste

Sheets("Sheet2").Select
sht2gyosu = Cells(Rows.Count, 1).End(xlUp).Row
' MsgBox sht2gyosu
Range(Cells(2, 1), Cells(sht2gyosu, 5)).Select


Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
sht4gyotop = sht1gyosu + 1
sht4gyoend = sht1gyosu + sht2gyosu
Range(Cells(sht4gyotop, 1), Cells(sht4gyoend, 5)).Select
Range("A8").Select
ActiveSheet.Paste
Range("A1:E15").Select
Application.CutCopyMode = False
Selection.AutoFilter
Selection.AutoFilter Field:=4, Criteria1:="<>"
Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Key2:=Range("A2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End Sub

No.2 回答者： tom04 回答日時： 2013/06/14 23:18

No.1です！

前回のコードで2か所訂正してください。
仮に10月～12月のデータがあると2月よりも先に表示されてしまいます。

前回のコードで
＞.Formula = "=MONTH(F2)&""月"""
の行を
＞.Formula = "=MONTH(F2)"
に

そして
＞.Range("A:A").NumberFormatLocal = "0""月"""
の1行を
最後から5行目
>.Columns.AutoFit
と
＞End With
の間に追加して

With wS3
.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.Range("A1").Resize(1, 5).HorizontalAlignment = xlCenter
.Columns.AutoFit
.Range("A:A").NumberFormatLocal = "0""月"""
End With

これでSheet3のA列が昇順で表示されると思います。
何度も失礼しました。m(_ _)m

No.1 回答者： tom04 回答日時： 2013/06/14 22:50

こんばんは！

SheetはSheet1（A社）・Sheet2（B社）とSheet3だけという前提です。
VBAになりますが一例です。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）
尚、Sheet1のSheet名はA社・Sheet2はB社という名前になっているとします。

Sub Sample1() 'この行から
Dim i As Long, endRow, wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet, wS4 As Worksheet
Set wS1 = Worksheets("A社") '←Sheet名は実際のSheet名に！
Set wS2 = Worksheets("B社") '←Sheet2も同様！
Set wS3 = Worksheets("Sheet3") '←Sheet3も・・・

Application.ScreenUpdating = False
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "作業用"
Set wS4 = Worksheets("作業用")
On Error Resume Next
endRow = wS3.Cells(Rows.Count, "B").End(xlUp).Row
If endRow > 1 Then
wS3.Rows(2 & ":" & endRow).ClearContents
End If
With wS4
wS1.Range("A1").Resize(1, 5).Copy .Range("C1")
wS1.Cells(1, "D").AutoFilter field:=4, Criteria1:="<>"
i = wS1.Cells(Rows.Count, "A").End(xlUp).Row
If i > 1 Then
Range(wS1.Cells(2, "A"), wS1.Cells(i, "E")).Copy .Cells(Rows.Count, "C").End(xlUp).Offset(1)
End If
endRow = .Cells(Rows.Count, "C").End(xlUp).Row
Range(.Cells(2, "B"), .Cells(endRow, "B")).SpecialCells(xlCellTypeBlanks) = wS1.Name
wS1.AutoFilterMode = False
wS2.Cells(1, "D").AutoFilter field:=4, Criteria1:="<>"
i = wS2.Cells(Rows.Count, "A").End(xlUp).Row
If i > 1 Then
Range(wS2.Cells(2, "A"), wS2.Cells(i, "E")).Copy .Cells(Rows.Count, "C").End(xlUp).Offset(1)
End If
endRow = .Cells(Rows.Count, "C").End(xlUp).Row
Range(.Cells(2, "B"), .Cells(endRow, "B")).SpecialCells(xlCellTypeBlanks) = wS2.Name
wS2.AutoFilterMode = False
i = wS4.Cells(Rows.Count, "B").End(xlUp).Row
With Range(wS4.Cells(2, "A"), wS4.Cells(i, "A"))
.Formula = "=MONTH(F2)&""月"""
.Value = .Value
End With
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
Range(.Cells(2, "A"), .Cells(endRow, "G")).Copy wS3.Range("A1")
With wS3.Range("A1")
.Value = "発注一覧表"
.Offset(, 1) = "得意先"
wS1.Range("A1").Resize(1, 5).Copy .Range("C1")
End With
Range(.Cells(2, "A"), .Cells(endRow, "G")).Copy wS3.Range("A2")
wS3.Range("E:F").Delete
For i = wS3.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If wS3.Cells(i, "A") = wS3.Cells(i - 1, "A") Then
wS3.Cells(i, "A").ClearContents
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
With wS3
.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
.Range("A1").Resize(1, 5).HorizontalAlignment = xlCenter
.Columns.AutoFit
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m