エクセルで、複数ブックの表を効率的に集計する方法

質問

エクセルで、複数ブックの表を効率的に集計する方法を考えています。
定型の集計用シートがあり、Ａさん、Ｂさん、Ｃさんの３人が記入するとします。
その結果できたシート（シートａ、シートｂ、シートｃとします）を以下の２つの方法で集計したいと考えています。
（１）串刺し。上記の様式と同じかたちの集計シートを作成し、各項目ごとに数字を合算。
（２）縦並びの一覧表。
シートａの項目、シートｂの項目、シートｃの項目が縦に並ぶ一覧表です。
ちなみに、上記３シートは、同一ブックではなく、異なるブック（ファイル）です。
この例のように、３つくらいのデータをまとめるのであれば、手作業でなんとでもなるのですが、実際は、数十～百数十のデータの集計を考えています。
こういう作業を効率的に行う「方法」か「アプリケーション」はありますでしょうか？
ちなみに、「Excelシート差込アドイン」というアプリケーションを使って少し省力化できました。

回答No.3

noname#95859

ANo2の置き換え版です。実際の業務の使用に耐えるようなものを考えてみました。
但し、アップロードのバイト数制限から、DataCollectionのみとなっています。
MakeSummationの部分は、マニュアルで簡便に実施する方法として、出来上がった縦並び一覧表をACCESSに
インポートし、Groupbyで、合計を取れば、いとも簡単に「串刺しの合計」は求めることができます。

考え方：
（１）縦並びの一覧表を先に作ります。
（２）縦並びの一覧表をソートした上で、合計を求めます。
（３）エラー対策（データファイルが無い場合、データシートが無い場合・・等）
（４）途中結果を残す。データの出所（ファイル名,シート名）もわかるようにする。
－－－－－－－－－－－－－－－－
Job.xls：VBAを置いておくエクセルファイル。
これを、新規に作成していただき、下記のコードをVBA editor画面にコピーする。
その上で、シート上に３つのボタンを設定し、それぞれに
　－DataCollection
　－MakeSummation　（除外）
　－SummaryFileOpen（除外）
を登録する。
これが終了した時点で、とにかくDataCollectionのボタンを押してください。
------------------------------
RefTable.xls:定義ファイルです。自動で生成されます。マクロは停止しますので、サンプル（隣のシート）
からコピーしてください。例題のレベルで話をしています。
A列は、ファイル名
B列、C列等は、シート名
---------------------------------------
再度、Job.xlsに戻って、DataCollectionのボタンを押してください。
何も無く、終了してしまいますが、定義ファイルに登録したファイルがJob.xlsと同じフォルダにできています。
test1.xls等に、下記のデータを入力してください。
重要事項：横4列、縦14行です。これは、コードの中で与えれています。
--設定情報(データの範囲）--
myTitle = "A1:D1" 'ヘッダの範囲
DataArea = "A2:D14" 'データの範囲
つまり、貴兄のデータに合わせて、この部分を変更することが必要です。

Date ItemA ItemB ItemC
2007/1/1 1 1 1
2007/1/2 1 1 1
2007/1/3 1 1 1
2007/1/4 1 1 1
2007/1/5 1 1 1
2007/1/6 1 1 1
2007/1/7 1 1 1
2007/1/8 1 1 1
2007/1/9 1 1 1
2007/1/10 1 1 1
2007/1/11 1 1 1
2007/1/12 1 1 1
2007/1/13 1 1 1
-----------------------------
test2.xls,test3.xls,test4.xlsについても同様です。但し、シート名を定義ファイルで登録したものに変更してください。
----------------------------
将来の課題。
ファイルが存在しない時の対策は、ファイルシステムのFileExists関数を使う
処理対象のファイル名、シート名の自動収集：定義ファイルの自動生成
設定情報(データの範囲）の与え方を考える。コード(DataArea = "A2:D14")で記述しない。

前回の書き込み(ANo2)は、無視してください。今回のコードで置き換えてください
------次の行から最後までをVBAeditor画面にコピーします---------
Option Explicit

Sub DataCollection()
Dim DataFolderName As String, hani As String
Dim myTitle As String, DataArea As String
Dim SummaryFileName As String, SummaryTableSheet As String, SummationSheet As String
Dim ReferenceFileName As String, ReferenceSheetName As String
Dim r As Integer, c As Integer, NoOfFile As Integer, mysheets As Integer, mycolor As Integer
Dim TestPosition As Double
Dim myArray As Variant, myTitleArray As Variant, myDataArray As Variant
Dim FlagDataFileMissing As Boolean
Dim No_Item As Integer, rowpos As Double
Dim FileSheetName As String

'----------- 設定情報(集計先のファイル）-----------------------------------------------------------
SummaryFileName = "Summary.xls" '集計用のEXCELブック（自動で生成される）
SummaryTableSheet = "SummaryTable" '集計（縦並びの一覧表）のシート
SummationSheet = "SummaryValue" '集計（値）のシート
'----------- 設定情報(データの範囲）------------------------------------------------------------------
myTitle = "A1:D1" 'ヘッダの範囲
DataArea = "A2:D14" 'データの範囲
'----------- 設定情報(データファイル,シートの情報）------------------------------------------------------------------
ReferenceFileName = "RefTable.xls"
ReferenceSheetName = "Ref" 'このシートＡさん(シートａ)、Ｂさん(シートｂ)、Ｃさん(シートｃ)等の情報を記述する

' -------Reference tableをオープンし、変換情報をVariant（メモリ上の配列）に記憶する
DataFolderName = ThisWorkbook.Path
On Error GoTo ReferenceFileCreate
If FileOpened(ReferenceFileName) = False Then Workbooks.Open Filename:=DataFolderName & "\" & ReferenceFileName
On Error GoTo 0
If SheetExist(ReferenceFileName, ReferenceSheetName) = False Then Workbooks(ReferenceFileName).Worksheets.Add.Name = ReferenceSheetName
hani = Workbooks(ReferenceFileName).Worksheets(ReferenceSheetName).UsedRange.Address
If hani = "$A$1" Then
MsgBox ("データファイル名、データシート名の定義ができていません" & vbCrLf & "サンプルを参考にして、定義を記述してください")
Exit Sub
End If

myArray = Range(hani).Value
r = UBound(myArray, 1) 'rには、ファイルの数が入る
c = UBound(myArray, 2) 'cには、最大のシート数が入る
Workbooks(ReferenceFileName).Close SaveChanges:=False
On Error GoTo SummaryFileCreate
If FileOpened(SummaryFileName) = False Then Workbooks.Open Filename:=DataFolderName & "\" & SummaryFileName
On Error GoTo 0
If SheetExist(SummaryFileName, SummaryTableSheet) = False Then Workbooks(SummaryFileName).Worksheets.Add.Name = SummaryTableSheet
Workbooks(SummaryFileName).Worksheets(SummaryTableSheet).Cells.ClearContents
Workbooks(SummaryFileName).Worksheets(SummaryTableSheet).Cells.Interior.ColorIndex = xlNone
Application.DisplayAlerts = False
If SheetExist(SummaryFileName, "Temp" & SummationSheet) = True Then Workbooks(SummaryFileName).Worksheets("Temp" & SummationSheet).Delete
If SheetExist(SummaryFileName, SummationSheet) = True Then Workbooks(SummaryFileName).Worksheets(SummationSheet).Delete
Application.DisplayAlerts = True

'-------対象となる業務ファイルをオープンし、メモリ上の配列を参考に情報を書き写す。
For NoOfFile = 1 To r 'Aさん、Bさんのデータファイルを順番にオープン
On Error GoTo DataFileNissing
If FileOpened(myArray(NoOfFile, 1)) = False Then Workbooks.Open Filename:=DataFolderName & "\" & myArray(NoOfFile, 1)
On Error GoTo 0
If FileOpened(myArray(NoOfFile, 1)) = True Then
With Workbooks(myArray(NoOfFile, 1))
If InStr(UCase(myArray(NoOfFile, 2)), "ALL") > 0 Then
For mysheets = 1 To Sheets.Count 'ALLの場合は、全シート故 1からはじめる
hani = .Worksheets(mysheets).UsedRange.Address
myTitleArray = .Worksheets(mysheets).Range(myTitle).Value
No_Item = UBound(myTitleArray, 2) - 1
If hani <> "$A$1" Then
myDataArray = .Worksheets(mysheets).Range(DataArea).Value
With Workbooks(SummaryFileName).Worksheets(SummaryTableSheet)
TestPosition = .Cells(65536, 1).End(xlUp).Row
If TestPosition = 1 Then
.Range(myTitle).Value = myTitleArray
.Range(DataArea).Value = myDataArray
.Cells(TestPosition + 1, 1 + No_Item + 1).Value = myArray(NoOfFile, 1) & "/" & Workbooks(myArray(NoOfFile, 1)).Worksheets(mysheets).Name
Else
.Range(DataArea).Offset(TestPosition - 1, 0).Value = myDataArray
.Cells(TestPosition + 1, 1 + No_Item + 1).Value = myArray(NoOfFile, 1) & "/" & Workbooks(myArray(NoOfFile, 1)).Worksheets(mysheets).Name
End If
End With
End If
Next mysheets
Else '指定されたシート名を順に処理する
For mysheets = 2 To c
If myArray(NoOfFile, mysheets) <> "" Then
If SheetExist(myArray(NoOfFile, 1), myArray(NoOfFile, mysheets)) = True Then
hani = .Worksheets(myArray(NoOfFile, mysheets)).UsedRange.Address
myTitleArray = .Worksheets(myArray(NoOfFile, mysheets)).Range(myTitle).Value
No_Item = UBound(myTitleArray, 2) - 1
If hani <> "$A$1" Then
myDataArray = .Worksheets(myArray(NoOfFile, mysheets)).Range(DataArea).Value
With Workbooks(SummaryFileName).Worksheets(SummaryTableSheet)
TestPosition = .Cells(65536, 1).End(xlUp).Row
If TestPosition = 1 Then
.Range(myTitle).Value = myTitleArray
.Range(DataArea).Value = myDataArray
.Cells(TestPosition + 1, 1 + No_Item + 1).Value = myArray(NoOfFile, 1) & "/" & Workbooks(myArray(NoOfFile, 1)).Worksheets(myArray(NoOfFile, mysheets)).Name
Else
.Range(DataArea).Offset(TestPosition - 1, 0).Value = myDataArray
.Cells(TestPosition + 1, 1 + No_Item + 1).Value = myArray(NoOfFile, 1) & "/" & Workbooks(myArray(NoOfFile, 1)).Worksheets(myArray(NoOfFile, mysheets)).Name
End If
End With
End If
End If
End If
Next mysheets
End If
End With
Workbooks(myArray(NoOfFile, 1)).Close SaveChanges:=False 'Aさん、Bさんのデータファイルを閉じる
End If
Next NoOfFile

With Workbooks(SummaryFileName).Worksheets(SummaryTableSheet)
rowpos = 2
FileSheetName = ""
Do While .Cells(rowpos, 1).Value <> ""
If .Cells(rowpos, 1 + No_Item + 1).Value = "" Then
.Cells(rowpos, 1 + No_Item + 1).Value = FileSheetName
.Cells(rowpos, 1 + No_Item + 1).Interior.ColorIndex = mycolor
Else
FileSheetName = .Cells(rowpos, 1 + No_Item + 1).Value
If (mycolor Mod 3) = 0 Then mycolor = 34 Else mycolor = 6
.Cells(rowpos, 1 + No_Item + 1).Interior.ColorIndex = mycolor
End If
rowpos = rowpos + 1
Loop
End With
Workbooks(SummaryFileName).Close SaveChanges:=True 'サマリーファイルを閉じる
MsgBox ("終了")
Exit Sub

ReferenceFileCreate:
Workbooks.Add.SaveAs Filename:=DataFolderName & "\" & ReferenceFileName
Sheets(1).Select
Sheets(1).Name = "サンプル"
ActiveWorkbook.Sheets("サンプル").Tab.ColorIndex = 3
Range("A1").Value = "test1.xls"
Range("B1").Value = "Sheet1"
Range("A2").Value = "test2.xls"
Range("B2").Value = "test1"
Range("C2").Value = "test2"
Range("A3").Value = "test3.xls"
Range("B3").Value = "all"
Range("A4").Value = "test4.xls"
Range("B4").Value = "Sheet1"
Range("C4").Value = "Sheet2"
Range("D4").Value = "Sheet3"
Range("E4").Value = "Sheet4"
Resume Next

SummaryFileCreate:
Workbooks.Add.SaveAs Filename:=DataFolderName & "\" & SummaryFileName
Resume Next

DataFileNissing:
Workbooks.Add.SaveAs Filename:=DataFolderName & "\" & myArray(NoOfFile, 1)
Resume Next
End Sub

Public Function FileOpened(ByVal TestFileName As String) As Boolean
Dim DataFolderName As String
Dim test As Integer
DataFolderName = ThisWorkbook.Path
FileOpened = False
For test = 1 To Workbooks.Count
If Workbooks(test).Name = TestFileName Then FileOpened = True
Next
End Function

Public Function SheetExist(ByVal TestFileName As String, ByVal TestSheetName As String) As Boolean
Dim DataFolderName As String
Dim test As Integer
DataFolderName = ThisWorkbook.Path
SheetExist = False
For test = 1 To Workbooks(TestFileName).Worksheets.Count
If Workbooks(TestFileName).Worksheets(test).Name = TestSheetName Then SheetExist = True
Next
End Function

回答No.2

noname#95859

参考までに、作ってみました。
考え方：
（１）縦並びの一覧表を先に作ります。
（２）縦並びの一覧表をPIVOTで処理して合計を求めます。
－－－－－－－－－－－－－－－－
Job.xls：VBAを置いておくエクセルファイル。
これを開いて、
（１）procedure MakeSummaryを走らせる。
（２）procedure MakeSummation(未完）を走らせる。
------------------------------
RefTable.xls:定義ファイルです。どのエクセルファイルの
どのシートを対象とするのか記述しておきます。
例：セルA1から
test1.xls Sheet1
test2.xls test1 test2
test3.xls all
test4.xls Sheet1 Sheet2 Sheet3 Sheet4
A列は、ファイル名
B列、C列等は、シート名
---------------------------------------
test1.xlsには、下記のデータが入っているものとします。
Date ItemA ItemB ItemC
2007/1/1 1 1 1
2007/1/2 1 1 1
2007/1/3 1 1 1
2007/1/4 1 1 1
2007/1/5 1 1 1
2007/1/6 1 1 1
2007/1/7 1 1 1
2007/1/8 1 1 1
2007/1/9 1 1 1
2007/1/10 1 1 1
2007/1/11 1 1 1
2007/1/12 1 1 1
2007/1/13 1 1 1
-----------------------------
test2.xls,test3.xls,test4.xlsについても同様です。
-------------
job.xlsに、下記のprocedureをコピーしてください。
Sub MakeSummary()
Dim Datapath As String, hani As String
Dim myTitle As String, DataArea As String
Dim r As Integer, c As Integer, NoOfFile As Integer, mysheets As Integer
Dim test As Double
Dim myArray As Variant, myTitleArray As Variant, myDataArray As Variant

myTitle = "A1:D1"
DataArea = "A2:D14"

' -------Reference tableをオープンし、変換情報をVariant（メモリ上の配列）に記憶する
Datapath = ThisWorkbook.Path
Workbooks.Open Filename:=Datapath & "\" & "RefTable.xls"
Sheets("Ref").Select
hani = ActiveSheet.UsedRange.Address
myArray = Range(hani).Value
r = UBound(myArray, 1)
c = UBound(myArray, 2)
Workbooks("RefTable.xls").Close SaveChanges:=False

Workbooks.Open Filename:=Datapath & "\" & "Sum.xls"
On Error Resume Next
Sheets.Add.Name = "Summary"
On Error GoTo 0
Worksheets("Summary").Select
Cells.ClearContents

'-------対象となる業務ファイルをオープンし、メモリ上の配列を参考に情報を書き写す。
For NoOfFile = 1 To r
Workbooks.Open Filename:=Datapath & "\" & myArray(NoOfFile, 1) '
With Workbooks(myArray(NoOfFile, 1))
If InStr(UCase(myArray(NoOfFile, 2)), "ALL") > 0 Then
For mysheets = 1 To Sheets.Count '全シート故 1から
myTitleArray = .Worksheets(mysheets).Range(myTitle).Value
myDataArray = .Worksheets(mysheets).Range(DataArea).Value
With Workbooks("Sum.xls").Worksheets("Summary")
test = .Cells(65536, 1).End(xlUp).Row
If test = 1 Then
.Range(myTitle).Value = myTitleArray
.Range(DataArea).Value = myDataArray
Else
.Range(DataArea).Offset(test - 1, 0).Value = myDataArray
End If
End With
Next mysheets
Else
For mysheets = 2 To c
If myArray(NoOfFile, mysheets) <> "" Then
myTitleArray = .Worksheets(myArray(NoOfFile, mysheets)).Range(myTitle).Value
myDataArray = .Worksheets(myArray(NoOfFile, mysheets)).Range(DataArea).Value
With Workbooks("Sum.xls").Worksheets("Summary")
test = .Cells(65536, 1).End(xlUp).Row
If test = 1 Then
.Range(myTitle).Value = myTitleArray
.Range(DataArea).Value = myDataArray
Else
.Range(DataArea).Offset(test - 1, 0).Value = myDataArray
End If
End With
End If
Next mysheets
End If
End With
Workbooks(myArray(NoOfFile, 1)).Close SaveChanges:=False
Next NoOfFile
Workbooks("Sum.xls").Close SaveChanges:=True
End Sub
----------------------
また、後日、残りのprocedureと、なぜ、このようにしたのかを説明いたします。

回答No.1

noname#95859

VBAを使うのが一番と考えます。
考え方
データシートの決められたエリヤをそのまま、メモリ上の配列にもってきます。
ターゲット１（串刺し）に対応するメモリ上の配列を別に用意します。
ターゲット２（縦並び）は、ターゲット１を直接別のファイルにコピーしてしまいます。
データシートをForループでまわして、それぞれのシートをターゲット１、ターゲット２に持ってきます。

sub myArray()
dim myArrayIn as Variant
　dim myArrayOut as Variant

for i=1 to データシート数
hani=一行目を除いたエリヤ '一行目を除くのは、縦並びの結合を簡単にするため
myArrayIn=range(hani).value　'データをメモリ上に持ってくる
r = UBound(myArrayIn, 1) ' データエリヤの行数
c = UBound(myArrayIn, 2) ' データエリヤの列数
for myr=1 to r '1行目からデータです
for myc=2 to c　'1列目は多分ヘッダーでしょうから省略
myArrayOut1(myr,myc)=myArrayOut1(myr,myc)+myArrayIn(myr,myc)
next c
next r

windows("異なるブック").activate
sheets("縦並び").select
temp=Range("A65536").End(xlUp).offset(1,0).row
エリヤ分をセレクト
Range(hani).offset(temp,0).value=myArrayOut1
next
end sub

ヘッダー、第1値列目の情報を入力することをもう少し考えなければいけませんが。とりあえず、こんな考えではどうでしょうか？
参考にしていただければ幸いです。

お礼

早速のご回答、ありがとうごいざいます。
あいにくＶＢＡのことがよくわからないのです。
こういうのをつかえば、効率的な作業ができるのですね。
時間を見て学んでみようかなと思います。
ありがとうございました！