エクセルで複数シートを一覧表にするには？

質問

教えてください。エクセルで複数シートを自動で別のシートに転記したいのですが、
やり方がわかりません。
各シートの空白部分を除いてデーターがある分だけを取り出して、金額に数式を入れて
合計金額を追加したいのですが・・・・・。
下記のような感じでできますか？　宜しくお願いいたします。　
　　Sheet1
　　　 商品名　　単価　　数量
　　　　　　　****　　　０００　　０００
　　　　　　　****　　　 ００　　　００
　　Sheet２
　　　 商品名　　単価　　数量
　　　　　　　****　　　０００　　０００
　　　　　　　****　　　 ００　　　００
　　Sheet３
　　　 商品名　　単価　　数量
　　　　　　　****　　　０００　　０００
　　　　　　　****　　　 ００　　　００

をSheet4に

　　シート名　商品名　　単価　　数量　　金額
　　Sheet1　　****　　　０００　　０００　　００００（単価×数量)
　　　　　　　　 ****　　　 ００　　　００　　００００（単価×数量)　
　　　　　　　　　　　　　　　　 　合計金額　　０００
　　Sheet２　商品名　　単価　　数量　　金額
　　　　　　　　****　　　０００　　０００　　００００（単価×数量)
　　　　　　　　****　　　 ００　　　００　　００００（単価×数量)　
　　　　　　　　　　　　　　　　　合計金額　　０００　
　　Sheet３　商品名　　単価　　数量　　金額
　　　　　　　　****　　　０００　　０００　　００００（単価×数量)
　　　　　　　　****　　　 ００　　　００　　００００（単価×数量)　
　　　　　　　　　　　　　　　　　合計金額　　０００

回答No.2

tom04

こんばんは！
VBAになってしまいますが・・・
一例です。

Sheet4の1行目（A～E列）の項目は入力済みという前提です。

Alt＋F11キー　→　画面左下の「This Workbook」をダブルクリック　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j, k As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet4")
Application.ScreenUpdating = False
i = ws.Cells(Rows.Count, 4).End(xlUp).Row
If i > 1 Then
Range(ws.Cells(2, 1), ws.Cells(i, 5)).ClearContents
End If
For k = 1 To 3
ws.Cells(Rows.Count, 2).End(xlUp).Offset(1, -1) = Worksheets(k).Name
i = Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Row
Range(Worksheets(k).Cells(2, 1), Worksheets(k).Cells(i, 3)).Copy Destination:= _
ws.Cells(Rows.Count, 2).End(xlUp).Offset(1)
Next k
For j = 2 To ws.Cells(Rows.Count, 2).End(xlUp).Row
If ws.Cells(j, 1) = "" Then
ws.Cells(j, 1) = ws.Cells(j - 1, 1)
End If
ws.Cells(j, 5) = ws.Cells(j, 3) * ws.Cells(j, 4)
Next j
For j = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 To 3 Step -1
If ws.Cells(j, 1) <> ws.Cells(j - 1, 1) Then
ws.Rows(j).Insert
With ws.Cells(j, 4)
.Value = "合計金額"
.Offset(, 1) = WorksheetFunction.SumIf(ws.Columns(1), ws.Cells(j - 1, 1), ws.Columns(5))
End With
End If
Next j
For j = ws.Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
If ws.Cells(j, 1) = ws.Cells(j - 1, 1) Then
ws.Cells(j, 1).ClearContents
End If
Next j
Application.ScreenUpdating = True
End Sub 'この行まで

※　関数でないので、データ変更があってもSheet4にすぐに反映されません。
データ変更があるたびにマクロを実行する必要があります。

ご希望の方法でなかったらごめんなさいね。m(_ _)m

お礼

tom04さん、ありがとうございます。お礼が遅くなり申し訳ありません。
VBAはまだ初心者なのでよくわかりませんが、やってみます。本当に
ありがとうございました。

補足

何度も質問して申し訳ありません。
エクセルで複数シートを一覧表にすることはできたのですが、

Sheet1
　　　　A　　　　　　　　　　　B 　　　　　　　C　　　　　D　　　　E 　　F
　　　店 名 　　商 品 名 入 数 単価 数量 金額
　　益田養鶏所 　　白卵M10k 3,080 　4　　　　12320
　　益田養鶏所 　　うずらの卵1P 70 (空白) 　　　0
　　益田養鶏所 　　　　（空白）　　　　　　　
　　　　　・
　　　　　・

Sheet2
　　店 名 商 品 名 入 数 単価 数量 金額
白石(アイス) ストロベリー4l 1,900 　2 　3800
白石(アイス) バニラ4l 　　　　　　2,000　　(空白) 　　　0
白石(アイス) ゆずシャーベット2l 1,100 　56 61600
白石(アイス) 抹茶4l 　　　　　　1,900 　　　0
白石(アイス) 　　　　　(空白)
　　　・
　　　・

Sheet3～　同じように複数のSheetがある

<現在の結果>一覧表
　　　　A　　　　　　　　　　　B 　　　　　　　C　　　　　D　　　　E 　　F
　　　店 名 　　商 品 名 入 数 単価 数量 金額
　　益田養鶏所 　　白卵M10k 3,080 　4　　　　12320
　　益田養鶏所 　　うずらの卵1P 70 (空白) 　　　0
　　益田養鶏所 　　　　（空白）
　　　　　・
　　　　　・
　　白石(アイス) ストロベリー4l 1,900 　2 　3800
　　白石(アイス) バニラ4l 　　　　　　2,000　　(空白) 　　　0
　　白石(アイス) ゆずシャーベット2l 1,100 　56 61600
　　白石(アイス) 抹茶4l 　　　　　　1,900 　　　0
　　白石(アイス) 　　　　　(空白)
　　　　　・
　　　　　・
となっていますが、
(1)数量が入力されているレコードだけを抽出し、
(2)各店ごとに合計金額を追加し、さらに
(3)合計金額の次の行に１行空白のレコードを追加したい
のですが、どう記述すればいいのかわかりません。どうが教えていただけないでしょうか？　

<現在のVBA>
Option Explicit
Sub 棚卸()
Dim mySheet As Worksheet, myRange As Range, tmpTable As Range
　　　　 '全てのワークシートを対象にループ処理
For Each mySheet In Worksheets
'全てのワークシートを対象にループ処理
If mySheet.Name <> "棚卸" Then
'棚卸シートは除く
Set myRange = Worksheets("棚卸").Range("A" & Rows.Count).End(xlUp).Offset(1)
　　　　　　 '最新レコードの転記位置を取得
Set tmpTable = mySheet.Range("A2").CurrentRegion
'転記元のセル範囲を取得
tmpTable.Rows("2:" & tmpTable.Rows.Count).Copy myRange
'見出しを除いた範囲を転記
End If
Next
End Sub

Sub シートレベルの名前定義()
Dim mySheet As Worksheet
For Each mySheet In Worksheets
If mySheet.Name <> "棚卸" Then
mySheet.Names.Add "棚卸テーブル", mySheet.Range("A2").CurrentRegion
　　　 '「棚卸テーブル」という名前を各シートごとに定義
End If
Next
End Sub

Sub 棚卸_2()
Dim mySheet As Worksheet, myRange As Range, tmpTable As Range
For Each mySheet In Worksheets
　　　　　　’すべてのワークシートを対象にループ処理
If mySheet.Name <> "棚卸" Then
'棚卸シートは除く
Set myRange = Worksheets("棚卸").Range("A" & Rows.Count).End(xlUp).Offset(1)
　　　　　　 '最新レコードの転記位置を取得
Set tmpTable = mySheet.Names("棚卸テーブル").RefersToRange
　 '転記元のセル範囲をシートレベルの名前付き範囲を使って取得
tmpTable.Rows("2:" & tmpTable.Rows.Count).Copy myRange
'見出しを除いた範囲を転記
End If
Next
End Sub

宜しくお願いいたします。

回答No.1

KURUMITO

完成までには大分苦労しました。
シート1から3までにはＡ列からＣ列までの1行目には項目名が有り、2行目から下方にデータがあるとします。
そこでシート4の作業ですが作業のための行を1行目から3行目までに用意します。
1行目にはシート名を入力することにしてＢ1セルにはＳｈｅｅｔ１，Ｃ1セルにはＳｈｅｅｔ2，Ｄ1セルにはＳｈｅｅｔ3と入力します。
2行目ではＢ2セルに次の式を入力して右横方向にドラッグコピーします。
3行目ではＡ3セルに0と入力したのちにＢ3セルには次の式を入力して右横方向にドラッグコピーします。

=IF(B2="","",SUM($B2:B2))

4行目は空の行として例えばＡ5セルには次の式を入力して下方にドラッグコピーします。

=IF(COUNTIF($3:$3,ROW(A1)-1)=1,IF(INDEX($1:$1,MATCH(ROW(A1)-1,$3:$3,0)+1)=0,"",INDEX($1:$1,MATCH(ROW(A1)-1,$3:$3,0)+1)),"")

Ｂ5セルには次の式を入力したのちにＥ5セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX($3:$3),"",IF(COUNTIF($3:$3,ROW(A1))=1,IF(COLUMN(A1)<=2,"",IF(COLUMN(A1)=3,"金額合計",SUM(INDEX($E$5:$E5,INDEX($3:$3,MATCH(ROW(A1)-1,$3:$3,1))+2):INDEX($E$5:$E5,INDEX($3:$3,MATCH(ROW(A1)-1,$3:$3,1)+1)-1)))),IF(COLUMN(A1)<=3,INDEX(INDIRECT(INDEX($1:$1,MATCH(ROW(A1)-1,$3:$3,1)+1)&"!A:C"),ROW(A1)-INDEX($3:$3,MATCH(ROW(A1)-1,$3:$3,1)),COLUMN(A1)),IF(COLUMN(A1)=4,IF($A5<>"","金額",$C5*$D5),""))))

これでお望みの表が5行目以降に表示されます。一度こちらの指示通りで試験してみてください。
3行までの作業の行は目障りでしたらそれらの行を選択したのちに右クリックして「非表示」にすればよいでしょう。

お礼

お手数をおかけて申し訳ありません。
早速やってみます。
本当にありがとうございました。
また、つまづいたら宜しくお願いいたします。

補足

何度も質問して申し訳ありません。
せっかく考えていただいたのですが、自分でもやってみてエクセルで複数シートを一覧表にすることはできたのですが、

Sheet1
　　　　A　　　　　　　　　　　B 　　　　　　　C　　　　　D　　　　E 　　F
　　　店 名 　　商 品 名 入 数 単価 数量 金額
　　益田養鶏所 　　白卵M10k 3,080 　4　　　　12320
　　益田養鶏所 　　うずらの卵1P 70 (空白) 　　　0
　　益田養鶏所 　　　　（空白）　　　　　　　
　　　　　・
　　　　　・

Sheet2
　　店 名 商 品 名 入 数 単価 数量 金額
白石(アイス) ストロベリー4l 1,900 　2 　3800
白石(アイス) バニラ4l 　　　　　　2,000　　(空白) 　　　0
白石(アイス) ゆずシャーベット2l 1,100 　56 61600
白石(アイス) 抹茶4l 　　　　　　1,900 　　　0
白石(アイス) 　　　　　(空白)
　　　・
　　　・

Sheet3～　同じように複数のSheetがある

<現在の結果>一覧表
　　　　A　　　　　　　　　　　B 　　　　　　　C　　　　　D　　　　E 　　F
　　　店 名 　　商 品 名 入 数 単価 数量 金額
　　益田養鶏所 　　白卵M10k 3,080 　4　　　　12320
　　益田養鶏所 　　うずらの卵1P 70 (空白) 　　　0
　　益田養鶏所 　　　　（空白）
　　　　　・
　　　　　・
　　白石(アイス) ストロベリー4l 1,900 　2 　3800
　　白石(アイス) バニラ4l 　　　　　　2,000　　(空白) 　　　0
　　白石(アイス) ゆずシャーベット2l 1,100 　56 61600
　　白石(アイス) 抹茶4l 　　　　　　1,900 　　　0
　　白石(アイス) 　　　　　(空白)
　　　　　・
　　　　　・
となっていますが、
(1)数量が入力されているレコードだけを抽出し、
(2)各店ごとに合計金額を追加し、さらに
(3)合計金額の次の行に１行空白のレコードを追加したい
のですが、どう記述すればいいのかわかりません。どうが教えていただけないでしょうか？　

<現在のVBA>
Option Explicit
Sub 棚卸()
Dim mySheet As Worksheet, myRange As Range, tmpTable As Range
　　　　 '全てのワークシートを対象にループ処理
For Each mySheet In Worksheets
'全てのワークシートを対象にループ処理
If mySheet.Name <> "棚卸" Then
'棚卸シートは除く
Set myRange = Worksheets("棚卸").Range("A" & Rows.Count).End(xlUp).Offset(1)
　　　　　　 '最新レコードの転記位置を取得
Set tmpTable = mySheet.Range("A2").CurrentRegion
'転記元のセル範囲を取得
tmpTable.Rows("2:" & tmpTable.Rows.Count).Copy myRange
'見出しを除いた範囲を転記
End If
Next
End Sub

Sub シートレベルの名前定義()
Dim mySheet As Worksheet
For Each mySheet In Worksheets
If mySheet.Name <> "棚卸" Then
mySheet.Names.Add "棚卸テーブル", mySheet.Range("A2").CurrentRegion
　　　 '「棚卸テーブル」という名前を各シートごとに定義
End If
Next
End Sub

Sub 棚卸_2()
Dim mySheet As Worksheet, myRange As Range, tmpTable As Range
For Each mySheet In Worksheets
　　　　　　’すべてのワークシートを対象にループ処理
If mySheet.Name <> "棚卸" Then
'棚卸シートは除く
Set myRange = Worksheets("棚卸").Range("A" & Rows.Count).End(xlUp).Offset(1)
　　　　　　 '最新レコードの転記位置を取得
Set tmpTable = mySheet.Names("棚卸テーブル").RefersToRange
　 '転記元のセル範囲をシートレベルの名前付き範囲を使って取得
tmpTable.Rows("2:" & tmpTable.Rows.Count).Copy myRange
'見出しを除いた範囲を転記
End If
Next
End Sub

宜しくお願いいたします。