【VBA】Excelファイルを開かずにデータを取り出したい【100本ノック】

今回もエクセルの神髄様の Twitter 企画「VBA100本ノック」の便乗させていただきます。 今回やってみるお題はその93本目です。 外部参照のスピルを使ってみます。

お題：VBA100本ノック 93本目：複数ブックを連結して再分割

#VBA100本ノック 93本目
「月別」フォルダには同一フォーマット（1シートのみ）の年月別のファイルがあります。
全データを集め、支店別に分割し直し「支店別」フォルダに「支店CD.xlsx」で出力してください。
フォーマットは画像及びサンプルファイルにて。
※「月別」「支店別」フォルダのパスは任意 pic.twitter.com/At32qZs8Hz

— エクセルの神髄 (@yamaoka_ss) 2021年2月22日

出題ページ

• VBA100本ノック 93本目：複数ブックを連結して再分割｜VBA練習問題

方針

実務でありそうな要件ですね。 これまでこの手のマクロがに全国でどれだけ繰り返し書かれてきたことでしょうか。

今時なら Power Query を使いたいところですが、それでは VBA の課題から外れてしまいます。

複数の XLSX ファイルを扱うマクロが面倒くさいのは、データを取り出すのにいちいちワークブックを開いたり閉じたりしなければならないことです。

Excel には閉じたままの Excel ファイルにアクセスできる機能がいくつかあります。

しかし難しいことを考えなくても、もともと Excel の数式は外部参照ができるのだから、別ファイルのデータをシート上に取得できるはずです。

試しに、外部参照をスピルさせてみると普通に外部データが展開されました。（スピルは Microsoft 365 （旧称 Office 365）版の Excel のみ）

これを使ってみます。

解答

Option Explicit

Sub VBA100_093()
    Dim srcFolderPath As String
    Dim dstFolderPath As String
    srcFolderPath = "D:\VBA100_93\月別"   'ThisWorkbook.Path & "\月別"
    dstFolderPath = "D:\VBA100_93\支店別" 'ThisWorkbook.Path & "\支店別"
    
    If srcFolderPath Like "http*" Then MsgBox "OneDrive には未対応です。", vbExclamation, Title:="VBA100_093": Exit Sub
    If Dir(srcFolderPath, vbDirectory) = "" Then MsgBox srcFolderPath & "が見つかりません。", vbExclamation, Title:="VBA100_093": Exit Sub
    If Dir(dstFolderPath, vbDirectory) = "" Then MsgBox dstFolderPath & "が見つかりません。", vbExclamation, Title:="VBA100_093": Exit Sub
    If Dir(srcFolderPath & "\*.xlsx") = "" Then Exit Sub
    
    Application.ScreenUpdating = False
    ThisWorkbook.Activate ' おまじない
    
    Dim tmpSht As Worksheet  ' 作業用ワークシート
    Set tmpSht = ThisWorkbook.Worksheets.Add
    tmpSht.Range("C:C").NumberFormat = "yyyy/mm/dd"  ' 書式はコピーされない
    tmpSht.Range("D:H").NumberFormat = "#,##0"
    
    On Error GoTo final
    ' 各ファイルのデータを結合する
    Dim concatData As Range
    Set concatData = tmpSht.Range("A1")
    Call concatDataFromFolder(srcFolderPath, "A1:H1000", concatData) ' "A1:H1000"は各シートのデータ範囲が十分収まるであろう行数のRange
    Set concatData = concatData.CurrentRegion
    ' 少なくとも見出し行が取得されていることをチェック
    If WorksheetFunction.CountA(concatData.Rows(1)) = 0 Or WorksheetFunction.CountIf(concatData.Rows(1), "<>0") = 0 Then
        Err.Raise 9999, Description:="不正なデータ形式です。"
    End If
    
    '結合データから支店CDを収集する
    Dim keys As Range
    Set keys = concatData.Range("A1").Offset(, concatData.Columns.Count + 1)
    keys.Value = "支店CD"
    Call extractUnique(concatData, keys.CurrentRegion)
    Set keys = keys.CurrentRegion
    keys.EntireColumn.AutoFit
    
    ' 支店別ファイルに分割保存する
    Call partitionIntoFiles(concatData, dstFolderPath, keys)
    
final:
    Application.DisplayAlerts = False
    tmpSht.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox Err.Description, vbExclamation, "VBA100_093"
End Sub

Sub concatDataFromFolder(srcFolderPath As String, ByVal srcAddress As String, dstRng As Range)
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(srcFolderPath)
    If folder.Files.Count = 0 Then Exit Sub
    
    Dim srcShadowRng As Range
    Set srcShadowRng = Range(srcAddress)

    Dim saveAlertMode As Boolean
    saveAlertMode = Application.DisplayAlerts
    Application.DisplayAlerts = False
    
    '最初のファイルから見出し行のみコピーする
    Set file = folder.Files(Dir(folder.Path & "\*.xlsx")) ' インデックスで取れない???
    dstRng.Range("A1").Formula2 = "=" & q(folder.Path & "\[" & file.Name & "]" & fso.GetBaseName(file)) & "!" & srcShadowRng.Rows(1).Address
    dstRng.SpillingToRange.Formula = dstRng.SpillingToRange.Value
        
    If srcShadowRng.Rows.Count > 1 Then
        ' 見出し行を除外
        Dim dataAddress As String
        dataAddress = Intersect(srcShadowRng, srcShadowRng.Offset(1)).Address
            
        ' 各外部ファイルのデータを展開する
        Dim spillCell As Range
        Set spillCell = dstRng.Range("A2")
        For Each file In folder.Files
            If LCase(fso.GetExtensionName(file)) = "xlsx" Then
                ' 外部参照のスピル
                ' UNIQUE関数で余分なセル範囲を除外
                spillCell.Formula2 = "=UNIQUE(" & q(folder.Path & "\[" & file.Name & "]" & fso.GetBaseName(file)) & "!" & dataAddress & ")"
                If spillCell.SpillingToRange.Rows.Count > 1 Then
                    With spillCell.SpillingToRange.Resize(spillCell.SpillingToRange.Rows.Count - 1) ' 最後のゴミ行は除外
                        .Formula = .Value
                        Set spillCell = spillCell.Offset(.Rows.Count)
                    End With
                End If
            End If
        Next
    End If
    
    Application.DisplayAlerts = saveAlertMode
End Sub

Sub extractUnique(srcTable As Range, dstFields As Range)
    srcTable.AdvancedFilter xlFilterCopy, CopyToRange:=dstFields, unique:=True
End Sub

Sub partitionIntoFiles(srcTable As Range, dstFolderPath As String, partitionKeys As Range)
    Dim fso As Object
    Dim folder As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(dstFolderPath)
        
    Dim tmpWbk As Workbook       ' 保存用ワークブック（使い回す）
    Dim prtSht As Worksheet      ' 出力用シート（使い回す）
    Set tmpWbk = Workbooks.Add
    Set prtSht = tmpWbk.Worksheets(1)
    
    Dim extract As Range ' 抽出先
    Dim criteria As Range ' 抽出条件
    Set extract = prtSht.Range("A1").Resize(, srcTable.Columns.Count)
    extract.Value = srcTable.Rows(1) ' 抽出先の見出しを設定
    Set criteria = extract.Range("A1").Offset(, srcTable.Columns.Count + 1)
    Set criteria = criteria.Resize(2, partitionKeys.Columns.Count) ' 複数キーにも対応
    
    On Error GoTo finish
    Dim saveAlertMode As Boolean
    saveAlertMode = Application.DisplayAlerts
    Application.DisplayAlerts = False
    
    ' 各支店CDについてデータを抽出しファイルを保存する
    Dim r As Long
    For r = 2 To partitionKeys.Rows.Count
        extract.CurrentRegion.Offset(1).ClearContents
        
        ' 支店CDで絞り込み抽出
        criteria.Rows(1).Value = partitionKeys.Rows(1).Value
        criteria.Rows(2).Value = partitionKeys.Rows(r).Value
        srcTable.AdvancedFilter xlFilterCopy, criteria, extract
        
        criteria.ClearContents
        prtSht.Names("Criteria").Delete
        prtSht.Names("Extract").Delete
        
        prtSht.Name = joinRangeText(partitionKeys.Rows(r))
        tmpWbk.SaveAs folder.Path & "\" & prtSht.Name & ".xlsx" ' ファイル名やシート名に使えない文字があるとエラー
    Next
finish:
    tmpWbk.Close SaveChanges:=False
    Application.DisplayAlerts = saveAlertMode
    If Err.Number <> 0 Then Err.Raise Err.Number
End Sub

Private Function q(str As String) As String
    q = "'" & Replace(Replace(str, "’", "’’"), "'", "''") & "'"
End Function

Private Function joinRangeText(rng As Range, Optional delim As String = " ") As String
    If rng.Cells.Count = 1 Then
        joinRangeText = rng.Cells(1).Text
    Else
        Dim txts() As String
        Dim c As Range
        Dim i As Long
        ReDim txts(rng.Cells.Count - 1)
        i = 0
        For Each c In rng.Cells
            txts(i) = c.Text
            i = i + 1
        Next
        joinRangeText = Join(txts, delim)
    End If
End Function

制約事項

• 本マクロでは、各ファイル内での重複データ行が排除（Distinct）されますので注意してください
• 本マクロはスピルを利用しているので、 Microsoft 365 版の Excel でしか動作しませんのでご了承ください。

---

---

考察

やっていることにしてはだいぶ長いプログラムになりました。

今後とも使い回しが利くようにちょっと汎用性を考慮したためです。 もう、この手のプログラムを書くのは最後にしたいと思います。

もし不具合を見つけられましたらコメントにてお知らせください。

外部参照数式

取得したいデータのシート名とセル範囲がわかっているのなら、外部参照の配列数式を使って Excel ファイルを開かずにデータを簡単に取り込むことができます。

='D:\VBA100_93\月別\[202004.xlsx]202004'!A1:E1000

Sub copyExternalRange(xlsxFilePath As String, srcSheetName As String, srcRngAddress As String, ByVal dstRng As Range)
    Dim xlsx As Object
    Set xlsx = CreateObject("Scripting.FileSystemObject").GetFile(xlsxFilePath)
    
    Set dstRng = dstRng.Resize(Range(srcRngAddress).Rows.Count, Range(srcRngAddress).Columns.Count)
    
    Application.DisplayAlerts = False
    dstRng.FormulaArray = "='" & xlsx.ParentFolder.Path & "\[" & xlsx.Name & "]" & srcSheetName & "'!" & srcRngAddress
    Application.DisplayAlerts = True
    
    dstRng.Formula = dstRng.Value
End Sub

パフォーマンスも Excel ファイルを開くのに比べれば圧倒的に速くなります。

問題は、ブック内のシート名やデータのセル範囲が分からないと時に、それを知る方法がないことです。

シート名はともかく、今回のお題のように行数の定まらない表データなどではセル範囲が確定できないので困ります。 数式で使える CurrentRegion のような関数はありません。

結局、データの規模から余裕をみて大きめのセル範囲を指定するしかありませんが、そうするとなぜか余分なセル範囲が 0 で埋められてしまいます。

動的配列数式とスピル

Microsoft 365 版の Excel がサポートする動的配列数式とスピルをうまく使えば、データ範囲のみの取得ができないこともありません。

もし、値が絶対に 0 にならない列があるのなら FILTER 関数が使えます。 ただし、数式を組み立てるのが面倒です。

=FILTER('D:\VBA100_93\月別\[202004.xlsx]202004'!A1:E1000, 'D:\VBA100_93\月別\[202004.xlsx]202004'!A1:A1000<>0, "")

もし、データ行が絶対に重複しないのであるなら UNIQUE 関数が使えます。 ただ、数式は簡単ですが、必ず最後に 0 のみの行が残ります。

=UNIQUE('D:\VBA100_93\月別\[202004.xlsx]202004'!A1:E1000)

いろいろ考えてみましたが、この２つしか方法はなさそうで、どちらも一長一短です。

お題のサンプルデータを見る限りデータ行の重複がなさそうなので、解答では UNIQUE 関数を使っています。

どちらもだめな状況では、すべての値が 0 になる行をクリアするロジックを VBA プログラムに追加するしかありませんが、それをするくらいならファイルを開いてしまった方が生産的でしょう。

---

---

技術的な補足

技術的な知見をメモしておきます。

• 動的配列数式を設定するには Range の Formula2 の方を使います。 詳しくは参考資料を参照してください。

• 最初の目論見では Evaluate メソッドでデータを変数にとって処理するつもりだったのですが、残念ながら Evaluate は外部参照に対応していないようです。
  裏ワザとして ExecuteExcel4Macro を使えば外部参照が取れるようですが、試してみたところ取れるのは１セルのみで配列数式には対応しないようです。

• 上記解答プログラムでは、外部参照のシングルクォート('と’)を２重にしてエスケープしていますが、シングルクォート自体を削除することでも動いてしまいます。
  Excel はシングルクォートを無視できるようですが、そういうものなのでしょうか。

• 外部参照は参照先のブックにシートが１枚しかないとき、シート名の照合はせずにその唯一のシートからデータを取得します。
  つまりシート名を知らなくても、シートが１枚しかない Excel ファイルなら適当なシート名（"hoge"とか）の指定でデータを取得できます。
  これって常識なんですかね。
  またもし、複数シートの Excel ファイルに対して、存在しないシート名を指定した場合、シートを選択するダイアログが表示されます。
  これは DisplayAlert = Falseで抑えられません。また、ダイアログで「キャンセル」を押した場合、エラーが飛びます。

• 上記解答プログラムでは https:// で始まる OneDrive 上のフォルダを除外していますが、それは VBA のファイル操作の事情からで、外部参照自体は OneDrive でも問題なく使えます。
  これに OneDrive 対応させる改修を行った場合（面倒ですが）、今度はクラウドを経由することによる読み込みのパフォーマンスが問題になるでしょう。
  上記解答プログラムでは、外部参照データを一つのシートで 1 ファイルずつ逐次的に処理していますが、 外部参照の数式を別々のシートで取るようにすれば、Excel の並列処理が利いてパフォーマンス向上できる可能性があると思っています。 未検証なので効果のほどは分りませんが、必要に迫られればやってみる価値はあります。

参考資料

• FormatCondition.Formula2 プロパティ (Excel) | Microsoft Docs
  目次ツリーに出てこない隠し文書
• セルの数式 | Microsoft Docs
  Microsoft さん、日本語が分かりません
• スピルでVBAの何が変わったか｜VBA技術解説
  神髄さんの分りやすい解説

関連記事

www.shegolab.jp