ExcelにはPowerクエリという機能があり、複数のExcelファイルに分散している表をひとつのシートにまとめることができます。
しかし、この機能では巷にはびこる神エクセルには対抗できません。Powerクエリでは表として整形されているデータ（A1：E10セルの範囲など）を集めることは簡単ですが、神エクセルがそんなにお行儀よくできてるわけないでしょMicrosoftさん。ビジネスの現場の98％（オレ調べ）を占める見た目優先、セル結合しまくりのExcelファイルに使えないのでは、この機能はないのも同然です。
今回はPowerクエリではまとめるのが困難なExcelファイルのデータをひとつにまとめます。
Powerクエリでは扱えないExcelファイル
次のようなシートに顧客情報が記録されています。データは架空個人情報生成サイトで作成したものです。完全にデータの再利用性を無視して見た目しか考えていませんが、これでも実務で遭遇するやつらに比べれば、まだかわいいもんです。私はパッと見える画面の範囲だけでAA列以上の列数を消費しているシートを見たことがあります。
このようなExcelファイルが顧客1人に1ファイルで顧客管理をしているとします。何故そんな非効率なことをしているのかは歴代の担当者から引き継がれているだけなので不明とします（あるある）。
Google先生に聞いた限りでは、Powerクエリではこのようなデータセルが不規則に配置されているシートからデータを集めることは、できなくはないようですが、めちゃくちゃ設定が大変そうでした。
ということで、その手間でVBAを書いた方が楽そうなので、やりましょう。
システム概要
処理のながれは
1.収集対象のセル番地のリストを取得する
2.データを取得したいExcelファイルを開く
3.そのファイルから対象のセル番地の値を取得する
4.ファイルの数だけ2-3を繰り返す
5.結果をシートに書き出す
となります。
すべてをコントロールするファイルを用意して、そこにVBAを書いていきます。これをexcel_collector.xlsmとして以降コレクターと呼称します。
収集するセル番地を指定するために、まず対象のファイルのどれかから、シートの内容をコレクターにコピペします。これは雛形となるため「テンプレート」シートと名付けます。
テンプレートシートで収集したいセルすべてに同一の塗りつぶし色を設定します。他で使用されている色とは別の色にします。セルの値は削除しておきます。
塗りつぶしたセルの取得順序をセルの値として入力します。言うまでもないですが数値としてです。
「設定」シートを用意して、各種設定値を記録しておきます。
収集したデータを書き出すために「データ」シートを用意します。
コレクターのテンプレートシートで指定の色に塗りつぶしたセルの番地をメモリーし、収集したいデータがあるファイルを順次開いていき同じシート名の同じセル番地からデータを取得、最後にまとめてコレクターのデータシートに書き出すということをやります。
解説
ソースコードです。
テンプレートシートはwsTemplate
設定シートはwsSetting
データシートはwsData
というオブジェクト名を付けています。
Option Explicit
Sub main()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim tgtDirPath As String
Dim tgtCellColor As Long
Dim tgtBookPath As String
Dim tgtSheetName As String
Dim lastUpdate As Date
Dim filePathCol As Long
With wsSetting
tgtSheetName = .Range("b2").Value
tgtDirPath = .Range("b1").Value
lastUpdate = .Range("b5").Value
filePathCol = .Range("b6").Value
End With
Dim tgtAddrs As Collection
Set tgtAddrs = getTgtAddrs
Dim r As Long
r = tgtAddrs.Count
Dim fp As String
fp = Dir(tgtDirPath & "\*.xls")
Dim cacheWs()
Dim cacheRow()
Dim fdt As Date
Dim lastFdt As Date
Dim c As Long
c = 0
lastFdt = lastUpdate
Do While Not fp = ""
tgtBookPath = tgtDirPath & "\" & fp
fdt = FileDateTime(tgtBookPath)
If lastUpdate < fdt Then
If lastFdt < fdt Then
lastFdt = fdt
End If
Dim wb As Workbook
Set wb = Workbooks.Open(tgtBookPath, ReadOnly:=True)
Dim i As Long
Dim j As Long
Dim isNew As Boolean
isNew = True
If filePathCol Then
Dim fpr As Long
fpr = getFpTgtRow(tgtBookPath, wsData.Columns(filePathCol))
If fpr Then
'ファイルパスがすでに記録してあるファイルはデータシート更新
ReDim cacheRow(r - 1)
For j = 1 To r
cacheRow(j - 1) = _
wb.Worksheets(tgtSheetName).Range(tgtAddrs(CStr(j))).Value
Next
With wsData
Range(.Cells(fpr, 1), .Cells(fpr, r)).Value = cacheRow
End With
isNew = False
End If
End If
'新規ファイルのデータは配列に格納
If isNew Then
ReDim Preserve cacheWs(r, c)
For i = 1 To r
cacheWs(i - 1, c) = _
wb.Worksheets(tgtSheetName).Range(tgtAddrs(CStr(i))).Value
'配列の最後にファイルパスを追加
If i = r Then
ReDim Preserve cacheWs(i, c)
cacheWs(i, c) = tgtBookPath
End If
Next
End If
wb.Close
c = c + 1
End If
fp = Dir()
Loop
If Not Not cacheWs Then
Dim er As Long
er = getEmptyRow(wsData)
Range(wsData.Cells(er, 1), wsData.Cells(er + c - 1, r + 1)).Value = _
WorksheetFunction.Transpose(cacheWs)
End If
wsSetting.Range("b5").Value = lastFdt
wsSetting.Range("b6").Value = r + 1
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub folderPicker(cellAddr As String)
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Range(cellAddr).Value = .SelectedItems(1)
End If
End With
End Sub
Function getTgtAddrs() As Collection
Dim tc As Collection
Set tc = New Collection
Dim tgtCellColor As Long
tgtCellColor = wsSetting.Range("b3").Interior.Color
Dim c As Range
For Each c In wsTemplate.UsedRange
If c.Interior.Color = tgtCellColor Then
If Not c.Value = "" Then
tc.Add c.Address, CStr(c.Value)
End If
End If
Next
Set getTgtAddrs = tc
End Function
Function getFpTgtRow(fp As String, tgtCol As Range) As Long
getFpTgtRow = 0
On Error Resume Next
getFpTgtRow = WorksheetFunction.Match(fp, tgtCol, 0)
On Error GoTo 0
End Function
Function getEmptyRow(ws As Worksheet) As Long
If ws.Cells(1, 1).Value = "" Then
getEmptyRow = 1
Else
getEmptyRow = ws.Cells(Rows.Count, 1).End(xlUp).row + 1
End If
End FunctiongetTgtAddrs関数はテンプレートシートの指定された背景色のセル番地をコレクションにして返します。指定された背景色＝設定シートのB3セルの背景色です。
このコレクションのキーはセルの値（＝数値）なのでコレクションから取り出すときに数値をインクリメントしながらキーにしてループさせることで順番に取り出せます。コレクションのキーは文字列しか受け付けないので、無駄に感じますが一度、数値を文字列にしてキーにする必要があります。
Dir関数で設定シートのパスのフォルダ内のファイルを走査していきます。
cacheWsは仮想ワークシート2次元配列です。cacheRowは仮想列1次元配列です。取得したデータはいったんこの仮想データ構造へ格納して最後に、せーので実際のシートへ書き出すようにしています。これは処理時間短縮のためです。
余談ですが、VBAの配列は使いづらすぎてやばいです。なんで初期化で要素数を指定しなければならないのか、なんでいちいちReDim Preserveなんてステートメントを入れなければならないのか･･･。ここの処理はコレクションや自作オブジェクトも考えたのですが、ループ回数が多くなるのでやむを得ず一番速いらしい配列にしました。
lastUpdate変数はフォルダ内のファイルの更新日時の最終値を保持しています。最初の1回の処理が終わったあとに設定シートに処理したファイルのうち最新の更新日時を記録しておき、次からは設定シートから取り出し、これとファイルの更新日時を比較してより新しいファイルのみ開くようにしています。
データシートの最終列には、そのデータをどのファイルから取得してきたかをパスで記録しています。getFpTgtRow関数は開いたファイルのパスがデータシートにすでに存在しているかを調べ、存在している場合は何行目かを数値で返します。パスが存在しているファイルのデータは、cacheRowへ格納され、1行分のデータがそろったらデータシートの該当するパスの行データを上書きします。
パスが存在していないファイルのデータはcacheWsへ追加されます。このすでに記録されているファイルか否かを管理するフラグがisNew変数です。
cacheWsが空ではない場合は最後にデータシートの末尾へ書き出します。配列が空かどうかは
Not Not 配列名 という条件式で判定できるようです。変なの。
使用方法
1.ページ下部のダウンロードボタンからExcelファイル（excel_collector.xlsm）を入手します。
2.データを収集したいファイル群をひとつのフォルダに保存します。
3.データを収集したいシートをテンプレートシートへコピペします。収集対象のセルのデータは削除します。
4.設定シートの取得セル色をテンプレートシートで使用していない適当な色に塗りつぶします。
5.テンプレートシートの取得対象セルを4.で設定した色へ塗りつぶします。
6.取得対象セルをどの順番で取得していくかを数値で入力します。
7.設定シートの取得シート名にデータを収集したいシートの名前を入力します。
8.設定シートの対象フォルダセルをダブルクリックするとフォルダ選択ダイアログが出るので、2.のフォルダを選択します。パスがセルに入ります。
9.mainプロシージャを実行します。
10.結果はデータシートへ記録されます。A列から設定した順に記録されていきますが、あらかじめ列名を入れておくとわかりやすいでしょう。
以降はフォルダ内で同じファイル名で更新されたファイルはデータシートの該当するデータ列が書き換わり、新しいファイルが追加された場合はデータの末尾に追加されていきます。
シート名が一定じゃない、全部のシートを対象にしたい、セル番地がファイルによってズレている、などそのままのコードでは対応できない場合は、ご自由にコードを書き換えてカスタマイズしてお使いください。
ファイルを入手する
いつも通りエラーハンドラーはないので、ご了承ください。
例のマルウェアの影響でMicrosoftが得体の知れない出所のマクロ実行に、さらなる制限をかけるようになりました。普通には実行できずにひと手間必要です。詳細はマクロ実行警告メッセージのヘルプを参照してください。
問題点と対策
実際に使用してみると、ファイルが大量にあると処理時間がめちゃくちゃかかることに気がつくでしょう。その対策として更新されたファイルしか開かないようにしているわけですが、VBAのファイルを開く処理は本当に遅いです。
100個のファイルを処理した場合の時間を計測してみます。取得する内容は先に使用した顧客情報と同じです。
20秒間何もできなくなります。
別の記事でも取り上げていますが、PythonでOpenPyXLを使ってExcelファイルを開くのは超速です。
なので、今回の内容をPythonスクリプトにしてみました。Pythonを実行できる環境があるのであれば、こちらをお使いいただくとストレスフリーです。処理時間は100ファイルで1秒です。
ソースコードです。ダウンロードしたExcelファイルに設定をしてこのスクリプトへドラッグ＆ドロップすると実行されます。
import os
import sys
from datetime import datetime
import openpyxl as excel
def main(path):
wb = excel.open(path, keep_vba=True)
wss = wb['設定']
wst = wb['テンプレート']
wsd = wb['データ']
tgt_color = wss['b3'].fill.fgColor.index
tgt_addrs = get_tgt_addrs(wst, tgt_color)
last_update = get_last_update(wss['b5'].value)
src_dir = wss['b1'].value
src_ws_name = wss['b2'].value
fp_col = get_fp_col(wss['b6'].value, tgt_addrs)
last_fdt = last_update
i = get_empty_row(wsd)
for f in os.listdir(src_dir):
fp = os.path.join(src_dir, f)
fdt = datetime.fromtimestamp(os.path.getmtime(fp)).replace(microsecond=0)
if last_update < fdt:
if last_fdt < fdt:
last_fdt = fdt
tgt_row = get_fp_tgt_row(wsd, fp_col, fp)
src_wb = excel.open(fp)
src_ws = src_wb[src_ws_name]
if tgt_row == 0:
# 新規ファイル
write(wsd, fp, i, fp_col, src_ws, tgt_addrs)
i += 1
else:
# 更新ファイル
write(wsd, fp, tgt_row, fp_col, src_ws, tgt_addrs)
if last_fdt is not None:
wss['b5'].value = last_fdt
wss['b6'].value = fp_col
wb.save(path)
def write(wsd, fp, i, last_cnt, src_ws, tgt_addrs):
for cnt, tc in enumerate(tgt_addrs):
wsd.cell(row=i, column=tc[0]).value = src_ws[tc[1]].value
if cnt == last_cnt - 2:
wsd.cell(row=i, column=cnt + 2).value = fp
def get_tgt_addrs(wst, tgt_color):
tgt_addrs = []
for r in wst.iter_rows():
for c in r:
if c.fill.fgColor.index == tgt_color:
tgt_addrs.append((c.value, c.coordinate))
tgt_addrs.sort(key=lambda x: x[0])
return tgt_addrs
def get_fp_tgt_row(wsd, tgt_col, fp):
for r in wsd.iter_rows(min_col=tgt_col):
if r[0].value is None:
return 0
elif r[0].value == fp:
return r[0].row
return 0
def get_last_update(val):
if val is None:
return datetime(1901, 1, 1, 0, 0, 0)
else:
return val.replace(microsecond=0)
def get_fp_col(val, tgt_addrs):
if val is None:
return len(tgt_addrs) + 1
else:
return val
def get_empty_row(wsd):
empty_row = 1
for i in reversed(range(1, wsd.max_row + 1)):
if wsd.cell(row=i, column=1).value:
empty_row = i
break
return empty_row
main(sys.argv[1])
基本VBAと同じ処理をしていますが、こちらではいちいちデータを配列に格納しないで、直接セル書き込みしています。OpenPyXLではそもそもブックがまるごと配列様のデータ構造で管理されているんじゃないかと思われ、配列格納最後に書き出し方式にしても速度向上はしなそうです（未確認）。
おわり。
