複数ブックからデータを抽出してリストを作成する方法

質問

• VBAを使用して、複数のブックから指定のデータを抽出し、リストを作成する方法を紹介します。
• 各地域ごとに分かれた複数のブックから、「一覧」シートを参照して商品名、メーカー、合計を抽出します。
• 月によって商品が増減するため、各地域別のブックを更新すると自動的にリストも更新されます。開かずにデータを抽出する方法も紹介します。

回答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

お礼

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