複数ブックから指定のデータを抽出してリストにしたい

質問

VBAで複数のブックから指定のデータを抽出してリストを作りたいです。
・地域ごとに分かれたブックが複数あります。（全て同一フォルダ内、リストも同フォルダに作ります）
・シートの構成は「原本」「一覧」「商品名A」「商品名B」（※5～20シート位）
・商品は月替わりで増減がある。

「一覧」…商品名のシートから月の販売個数を集計した物を一覧表にしてあります。
　　　　　必ず各ブックの2枚目のシートになります。

・各地域のブックから「一覧」のシートを参照して「商品名」「メーカー」「合計」を抽出する。
・リストには地域別でメーカー毎に一覧を表示したい。

別ブックの特定のセルを参照して一覧にするのは簡単なのですが、商品が毎月増減します。
なので各地域別のブックを更新したら、リストの方も自動的に反映されるようにしたいのです。
色々検索してみて各ブックの指定のシート、指定のセルからマクロで自動的に読み込むというのは見つかりましたが、セルの範囲が一定ではない場合はどうすれば良いのか解りません。

出来ればリスト以外のブックは開かずにデータを抽出したいです。
（※実際に入力作業を行うスタッフは本当に入力しか出来ないので、このブックを先に開いて～とかは混乱して出来ないようです。マクロで全てのファイルを開く等も勝手に閉じてしまったりするので避けたいです。）

回答No.2

queuerev2 · ベストアンサー

回答の続きです。
マクロ本体の動作に必要なFunctionプロシージャです。
これもリストのあるブックの標準モジュールに置いて下さい。

'リストに新しい地区を挿入し、その領域を返す
Function InsArea(ByVal ListSheet As Worksheet, ByVal AreaName As String, _
ByVal RowPosition As Long, ByVal DataRowsCount As Long) As Range
Dim RU As Long
Dim RL As Long
RU = RowPosition
RL = RowPosition + DataRowsCount
ListSheet.Range("b" & RU & ":d" & RL).Insert xlShiftDown
ListSheet.Range("b" & RU & ":d" & RU).Merge
ListSheet.Range("b" & RU).Value = AreaName
If DataRowsCount <= 0 Then
Set InsArea = ListSheet.Range("b" & RU & ":d" & RU)
Else
Set InsArea = ListSheet.Range("b" & RU + 1 & ":d" & RL)
End If
End Function

'地区のデータ領域を返す。
'引数はデータ領域左上のセル
'最下行は、下に結合セルがあればその前、
'なければデータが入力されている最下行のセルの１つ下
'列数は3
Function GetDataArea(DataAreaUL As Range) As Range
Dim MergedCells As Range
Dim Lowest As Range
Dim r As Range
Dim cc As Long
Dim Sh As Worksheet
cc = 3
Set Sh = DataAreaUL.Parent
Set MergedCells = FindMergedAll(DataAreaUL.EntireColumn)
If MergedCells Is Nothing Then
'set Lowest = GetLowest(DataAreaUL)
Set Lowest = Sh.Cells(Sh.Cells.Rows.Count, _
DataAreaUL.Column).End(xlUp).Offset(1)
Else
Set r = Intersect(Sh.Range(DataAreaUL, _
Sh.Cells(Sh.Cells.Rows.Count, _
DataAreaUL.Column)), MergedCells)
If r Is Nothing Then
'set Lowest = GetLowest(DataAreaUL)
Set Lowest = Sh.Cells(Sh.Cells.Rows.Count, _
DataAreaUL.Column).End(xlUp).Offset(1)
Else
Set Lowest = r(1).Offset(-1)
End If
End If
Set GetDataArea = Sh.Range(DataAreaUL, _
Sh.Cells(Lowest.Row, Lowest.Column + cc - 1))
End Function

'結合セルの検索
'セル範囲を引数にするとその範囲で検索開始、引数なしで次を検索
'IsMissing(Range1)使用のためRange1はVariant
Function FindMergedInRange(Optional ByVal Range1 As Variant) As Range
Static First As Range
Static Previous As Range
Static RangeToFind As Range
Dim Found As Range
If Not IsMissing(Range1) Then
Application.FindFormat.Clear
Application.FindFormat.MergeCells = True
Set RangeToFind = Range1
Set First = RangeToFind.Find(What:="", SearchFormat:=True)
If First Is Nothing Then
Set FindMergedInRange = Nothing
Else
Set FindMergedInRange = First.MergeArea
End If
Set Previous = First
Else
Set Found = RangeToFind.Find(What:="", after:=Previous, _
SearchFormat:=True)
If Found.Address = First.Address Then
Set FindMergedInRange = Nothing
Else
Set FindMergedInRange = Found.MergeArea
Set Previous = Found
End If
End If
End Function

'結合セルをすべて検索
Function FindMergedAll(ByVal Range1 As Range) As Range
Dim AllFound As Range
Dim Found As Range
Set AllFound = FindMergedInRange(Range1)
If Not AllFound Is Nothing Then
Do
Set Found = FindMergedInRange()
If Found Is Nothing Then
Exit Do
Else
Set AllFound = Union(AllFound, Found)
End If
Loop
End If
Set FindMergedAll = AllFound
End Function

'すべて検索した結合セルの中の文字列を検索
Function FindStrInMergedAll(ByVal Str As String, ByVal Range1 As Range, _
Optional ByVal LookAt As XlLookAt = xlWhole)
Dim MergedAll As Range
Set MergedAll = FindMergedAll(Range1)
If MergedAll Is Nothing Then
Set FindStrInMergedAll = Nothing
Else
Application.FindFormat.Clear
Set FindStrInMergedAll = MergedAll.Find(What:=Str, LookAt:=LookAt)
End If
End Function

お礼

お礼が遅くなって申し訳ありません。
詳細な回答、有難うございました。
いただいた回答を丸写しで終わらないように、しっかり勉強させていただこうと思います。

回答No.1

queuerev2

どこまで御希望に添えるかわかりませんが回答いたします。

ブックを開かずに内容を読む方法はありました。
http://officetanaka.net/excel/vba/tips/tips28.htm
今回初めて使ったのですが、低機能ではありますがある程度のことはできます。

今回は行数が一定しない表を読むのですが、開始位置が決まっていて途中に空行がないものとしました。
データの行か空行かの判別は、４行目以下で列Cに何か記入されているかどうかで行うことにしました。
（途中に空行があって、その数が特定できない場合などはブックを開くしかないと思います。それでもブックが開いているかどうか判定すればいいとは思いますが。）

書き込むリストの方ですが、その地域のデータを一旦すべて削除し、地域別ブックから読み込んだデータ数に応じてセルを挿入することにします。
リストに地域がない場合は追加するかどうかを質問したうえでリストの一番上に追加（挿入）することにします。
地域の判定ですが、まず地域別ブックのB2を読み、右４文字の「販売？？」を削除し、リストの地区名（列B）と比較して同じものがあればそこがその地域のデータであるとします。
リストにおいて、地区名はセルが結合されており、それ以外の列Bのセルは結合されていないものとしました。

質問画像のリストでは異なるメーカーの間に空行が入っていますが、今回のコードでは簡単のため入れていません。

読み込む地区のブックは開いていてもいなくてもいいのですが、できるだけExcelの複数起動は避けた方が無難です。
（通常は複数のブックを開いてもExcelは１つなので問題ありませんが）

コードはリストのあるブックの標準モジュールに置いて下さい。
リストのシート名は"Sheet1"としました。
地区のブック名はコードに直接書いていますので質問者様の状況に合わせて書き換えてください。

あとは実行するなりコードを読むなりしてみてください。
わからないところやうまくいかないところは補足いただければ、と思います。

コードを書いてみたのですがとても長くなってしまったので２つの回答に分けます。
すべてリストのあるブックの標準モジュールに置いて下さい。
以下はマクロ本体です。

Option Explicit
Sub ExtractToList1()
Dim AreaBooks As Variant
Dim BPath_d As String
Dim e, f, i As Long, j As Long
Dim Ex1 As Variant
Dim ExAN As String
Dim ExC As Collection
Dim ExRCn As String
Dim ABRow As Long
Dim LSh As Worksheet
Dim AreaA2() As Variant
Dim LP As Range
Dim r As Range
Dim RowsDA As Long
'初期化
'リストのあるシートを指定
Set LSh = ThisWorkbook.Sheets("Sheet1")
'ここに地区のブック名を書く
AreaBooks = Array("area1.xlsx", "area2.xls")
'フォルダ指定
BPath_d = ThisWorkbook.Path
If Right(BPath_d, 1) <> "\" Then
BPath_d = BPath_d & "\"
End If
'地区のブックを１つずつ処理
For Each e In AreaBooks
'データを読む
ABRow = 4
Set ExC = New Collection
Do
ExRCn = "'" & BPath_d & "[" & e & "]一覧'!R" & ABRow & "C"
Ex1 = ExecuteExcel4Macro(ExRCn & "3")
If Ex1 = 0 Or Ex1 = "" Then
Exit Do
End If
ExC.Add Array(Ex1, ExecuteExcel4Macro(ExRCn & "4"), _
ExecuteExcel4Macro(ExRCn & "9"))
ABRow = ABRow + 1
Loop
ReDim AreaA2(1 To ExC.Count, 2)
For i = 1 To ExC.Count
For j = 0 To 2
AreaA2(i, j) = ExC(i)(j)
Next
Next
ExAN = ExecuteExcel4Macro("'" & BPath_d & "[" & e & "]一覧'!R3C2")
ExAN = Trim(ExAN)
If ExAN Like "*販売??" Then
ExAN = Left(ExAN, Len(ExAN) - 4)
End If
'データを書き込む場所の準備
Set LP = FindStrInMergedAll(ExAN, LSh.Range("b:b"), xlWhole)
RowsDA = UBound(AreaA2, 1) - LBound(AreaA2, 1) + 2
If LP Is Nothing Then
'リストに地区がなければ尋ねてYesなら一番上に挿入
Select Case MsgBox("地区「" & ExAN & "」はリストにありません。" _
& vbNewLine & "新たに書き込みますか？", vbYesNoCancel)
Case vbNo
GoTo EndOfAreaBook:
Case vbCancel
Exit Sub
End Select
Set r = InsArea(LSh, ExAN, 2, RowsDA)
Set r = r.Resize(r.Rows.Count - 1)
Else
'リストに地区があるので一旦セルを削除してから挿入し直す
Set r = GetDataArea(LP(1).Offset(1))
If r.Rows.Count >= 2 Then
Set r = r.Resize(r.Rows.Count - 1)
r.Delete shift:=xlUp
End If
Set r = GetDataArea(LP(1).Offset(1))
r.Resize(RowsDA - 1).Insert shift:=xlDown
Set r = GetDataArea(LP(1).Offset(1))
Set r = r.Resize(RowsDA - 1)
End If
'リストにデータを書き込む
r.Value = AreaA2
'メーカーをキーにソート
With LSh.Sort
.SortFields.Clear
.SortFields.Add Key:=Intersect(LSh.Range("C:C"), r), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange r
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
EndOfAreaBook:
Next
End Sub