CSVファイルを使ってエクセルを共同編集する

OneDrive（SharePoint）の「共同編集」は大変魅力的な機能です。特にオンライン版のエクセルでは、完璧に機能していると思います。

ただし、デスクトップ版のエクセルでは正常に機能しないことも多いようです。特に、VBAを使ったファイルは共同編集できません。

さらに、法律事務所の場合、セキュリティ上の観点からOneDrive（SharePoint）上にファイルをそのまま置くことができない場合も多いと思います。（そもそもOneDriveを利用していない場合もあると思います。）

VBAアセットでは、CSVファイルを利用した簡易的なデータベースをエクセルの外部に作って、データをそこに保存できるようにしています。こうすれば、上記のような場合でも、データファイルを安全な領域に保存したうえで共同編集を行うことが可能になります。

CSVファイルはカンマを区切り文字に使うのが一般的ですが、データに「,」が使われることが考えられるため区切り文字にタブを使ったTSVファイルを使用しています。）

データ共有マクロ

WriteRecord

テーブルの行データをレコードファイルに書きこみます。
他の人が修正済みのファイルへの上書きを防止するため、タイムスタンプを確認してします。
ファイルへの書き込みが正常に行われたことを確認するため、書き込み後に読み込みを行っています。

引数：データベースフォルダ,テーブル名,レコード（テーブル行）番号,キー列の数

'================================================================================
' 機能:      テーブルの1行（レコード）を、個別のTSVファイルとして書き出します。
' 概要:      指定されたテーブルの行データから、キー列の値を組み合わせてファイル名を
'            生成します。そのファイル名でTSVファイルを作成し、キー以外の列データを
'            タブ区切りで書き込みます。書き込み後、確認のために再度読み込みを行います。
'================================================================================
Sub WriteRecord(strFolder As String, strTable As String, r As Long, lngKeys As Long)
'テーブルレコードをレコードファイルに書きこみます。
    'エラー処理を設定する
    On Error GoTo HdlErr
    
    'ステータスバーを表示する
    Application.StatusBar = "「" & strTable & "」テーブルの" & r & "行目をレコードファイルに書き込んでいます。"
        
    'すべてのキーデータ入力セルを繰り返す
    Dim cls As Range
    For Each cls In Range(Range(strTable)(r, 1), Range(strTable)(r, lngKeys))
        'データが入力されていない場合はエラー処理を行う
        If cls.Value = "" Then GoTo HdlErr
    Next
    
    'ファイル名を把握する
    'http://officetanaka.net/excel/vba/function/Join.htm
    'https://www.relief.jp/docs/excel-vba-woksheetfunction-textjoin.html
    Dim strFile
    strFile = WorksheetFunction.TextJoin("_", False, Range(Range(strTable)(r, 1), Range(strTable)(r, lngKeys))) & ".TSV"
    
    'レコードファイルが存在しない場合はスキップする
    If Dir(strFolder & "\" & strFile) = "" Then GoTo Continue
        
    'レコードファイルのタイムスタンプがテーブルレコードの更新日時と同一または古い場合はスキップする
    If Range(strTable)(r, Range(strTable).Columns.Count) >= FileDateTime(strFolder & "\" & strFile) Then GoTo Continue
        
    '上書きが拒否された場合
    If MsgBox("より新しいレコードファイルが存在します。" & vbCr & _
        "現在の行データでレコードファイルを上書きしてよろしいですか？", vbYesNo) = vbNo Then
        'レコードファイルのデータを読み込む
        TSV.ReadRecord strFolder, strTable, r, lngKeys
        
        '終了する
        Exit Sub
    End If
    
Continue:
    'レコードファイルを出力モードで開く
    'ファイルが存在しない場合は新規に作成されます。
    Open strFolder & "\" & strFile For Output As #1
        
    'フィールド列の値をタブで区切ってフィールド文字列を生成する
    'キー列の次の列から「更新日時」の手前列までのデータを取り込みます。
    'http://officetanaka.net/excel/vba/function/Join.htm
    'https://www.relief.jp/docs/excel-vba-woksheetfunction-textjoin.html
    Dim strField
    strField = WorksheetFunction.TextJoin(vbTab, False, _
        Range(Range(strTable)(r, lngKeys + 1), Range(strTable)(r, Range(strTable).Columns.Count - 1)))
    
    'フィールド文字列をレコードファイルに書き込む
    Print #1, strField
    
    'レコードファイルを閉じる
    Close #1
    
    'レコードファイルを読み込む
    'レコードファイルへの書き込みが完了したことを確認するため、直ちに読み込みを行います。
    Call ReadRecord(strFolder, strTable, r, lngKeys)
    
    'テーブル行のタイムスタンプを修正する
    Range(strTable)(r, Range(strTable).Columns.Count).Value = FileDateTime(strFolder & "\" & strFile)
       
    'ステータスバーを解除する
    Application.StatusBar = False
    Exit Sub
    
HdlErr:
    'エラーメッセージを表示する
    MsgBox "「" & strTable & "」テーブルの" & r & "行目をレコードファイルに書き込めませんでした。", vbExclamation
    
    'ステータスバーを解除する
    Application.StatusBar = False
    
    'すべてのファイルを閉じる
    Close
End Sub

ReadRecord

テーブルの行データをレコードファイルから読み込みます。

引数：データベースフォルダ名, テーブル名, レコード（テーブル行）番号,キー列の数

'================================================================================
' 機能:      個別のTSVファイルからデータを読み込み、テーブルの1行（レコード）を
'            更新します。
' 概要:      指定されたテーブルの行データからファイル名を特定し、対応するTSVファイルを
'            読み込みます。ファイルの内容をタブで分割し、テーブルのキー以外の列に
'            データを書き戻します。
'================================================================================
Sub ReadRecord(strFolder As String, strTable As String, r As Long, lngKeys As Long)
'テーブルレコードをレコードファイルから読み込みます。
    'エラー処理を設定する
    On Error GoTo HdlErr
    
    'メッセージを表示する
    'If MsgBox("レコードファイルで現在の行データを上書きしますか？", vbYesNo) = vbNo Then
    '    '処理を終了する
    '    Exit Sub
    'End If
    
    'ステータスバーを表示する
    Application.StatusBar = "「" & strTable & "」テーブルの" & r & "行目にレコードファイルを読み込んでいます。"
        
    'ファイル名を把握する
    'http://officetanaka.net/excel/vba/function/Join.htm
    'https://www.relief.jp/docs/excel-vba-woksheetfunction-textjoin.html
    Dim strFile
    strFile = WorksheetFunction.TextJoin("_", False, Range(Range(strTable)(r, 1), Range(strTable)(r, lngKeys))) & ".TSV"
    
    'レコードファイルを入力モードで開く
    Open strFolder & "\" & strFile For Input As #1
        
    'フィールド文字列を読み込む
    Dim strField
    Line Input #1, strField
    
    'レコードファイルを閉じる
    Close #1
    
    'フィールド文字列をテーブル行に書き込む
    'TextSplit関数はVBAでは使用できません。
    Range(Range(strTable)(r, lngKeys + 1), Range(strTable)(r, Range(strTable).Columns.Count - 1)) _
        = Split(strField, vbTab)
    
    'セルの値を入力しなおす
    'これを行わないと数値が文字列のままになります。
    Range(strTable).Rows(r).Value = Range(strTable).Rows(r).Value
    
    'タイムスタンプをテーブル行に書き込む
    Range(strTable)(r, Range(strTable).Columns.Count) = FileDateTime(strFolder & "\" & strFile)
    
    'ステータスバーを解除する
    Application.StatusBar = False
    Exit Sub
    
HdlErr:
    'エラーメッセージを表示する
        MsgBox "「" & strTable & "」テーブルの" & r & "行目をレコードファイルから読み込めませんでした。", vbExclamation
    
    'ステータスバーを解除する
    Application.StatusBar = False
    
    'すべてのファイルを閉じる
    Close
End Sub

WriteTable

テーブル全体をテーブルファイルに書き込んで、レコードファイルを削除します。
削除する前にテーブルファイルにレコードファイルの内容があることを確認しています。

引数：データベースフォルダ名,テーブル名,キー列の数

'================================================================================
' 機能:      テーブル全体のデータを1つのTSVファイル（Table.TSV）に集約して書き出し、
'            個別のレコードファイルを削除します。
' 概要:      テーブルの全行をループし、タブ区切りテキストとしてTable.TSVに書き込みます。
'            その後、データベースフォルダ内の個別のTSVファイルをチェックし、Table.TSVに
'            内容が含まれているものを削除してデータベースを整理します。
'================================================================================
Sub WriteTable(strFolder As String, strTable As String, lngKeys As Long)
'テーブル全体をテーブルファイルに書き込んで、レコードファイルを削除します。
    'エラー処理を設定する
    On Error GoTo HdlErr
       
    'ステータスバーを表示する
    Application.StatusBar = "「" & strTable & "」テーブルをテーブルファイルに書き込んでいます。"
    
    'テーブルにデータがない場合は終了する
    If Range(strTable)(1, 1) = "" Then GoTo HdlErr
    
    'テーブルファイルを出力モードで開く
    'ファイルが存在しない場合は新規に作成されます。
    Open strFolder & "\" & "Table.TSV" For Output As #1
            
    'テーブルのすべての行を繰り返す
    Dim r As Long
    For r = 1 To Range(strTable).Rows.Count
        'テーブルの行の文字列をテーブルファイルに書き込む
        'http://officetanaka.net/excel/vba/function/Join.htm
        'https://www.relief.jp/docs/excel-vba-woksheetfunction-textjoin.html
        Print #1, WorksheetFunction.TextJoin(vbTab, False, _
            Range(Range(strTable)(r, 1), Range(strTable)(r, Range(strTable).Columns.Count)))
    Next
            
    'テーブルファイルを閉じる
    Close #1
    
    'ステータスバーを表示する
    Application.StatusBar = "「" & strTable & "」テーブルのレコードファイルを削除しています。"
        
    'テーブルファイルを入力モードで開く
    Open strFolder & "\" & "Table.TSV" For Input As #1
    
    'テーブルファイル内のすべての行を繰り返す
    '全体の文字列を把握します。
    Dim strLineText As String, strWholeText As String
    Do Until EOF(1)
        '行の文字列を把握する
        Line Input #1, strLineText
        
        '全体の文字列に追加する
        strWholeText = strWholeText & vbCr & strLineText
    Loop
    
    'テーブルファイルを閉じる
    Close #1
    
    'データベース内のファイルを検索する
    Dim strFile
    strFile = Dir(strFolder & "\" & "*.TSV")
    
    'ファイルが存在する間
    Do While strFile <> ""
        'ファイルがテーブルファイルでなく、コピーファイルでもない場合
        If strFile <> "Table.TSV" And InStr(strFile, "(") = 0 Then
            'レコードファイルを入力モードで開く
            Open strFolder & "\" & strFile For Input As #1
                
            'フィールド文字列を読み込む
            Dim strField
            Line Input #1, strField
            
            'レコードファイルを閉じる
            Close #1
            
            'フィールド文字列がテーブルファイルに含まれている場合またはフィールド文字列が空の場合
            'テーブルファイルに書きこまれていないレコードファイルの削除を防止します。
            If InStr(strWholeText, strField) <> 0 Or Split(strField, vbTab)(0) = "" Then
                'レコードファイルを削除する
                Kill strFolder & "\" & strFile
            End If
        End If
        '次のファイルを読み込む
        strFile = Dir()
    Loop
    
    'ステータスバーを解除する
    Application.StatusBar = False
    Exit Sub
    
HdlErr:
    'ステータスバーを解除する
    Application.StatusBar = False
    
    'エラーメッセージを表示する
    MsgBox "「" & strTable & "」テーブルからテーブルファイルへの書き込みができませんでした。", vbExclamation
    
    'すべてのファイルを閉じる
    Close
End Sub

ReadTable

データベースから全てのデータを読み込んでテーブルを書き換えます。
読み込み速度を向上するため、テーブルの書式を解除してから行っています。

引数：データベースフォルダ名,テーブル名,キー列の数

'================================================================================
' 機能:       データベースから全てのデータを読み込み、シート上のテーブルを再構築します。
' 概要:       まずテーブルデータをクリアし、Table.TSVから基本データを読み込みます。
'             レコードTSVファイルで更新後、テーブルを再構築します。
'             これにより、シートに最新のデータベース状態が反映されます。
'================================================================================
Sub ReadTable(strFolder As String, strTable As String, lngKeys As Long)
    '--- 変数の宣言 ---
    Dim arrTable() As Variant      ' テーブル全体のデータを格納する動的配列（列, 行）
    Dim arrLine As Variant         ' TSVファイルの1行をタブで分割したデータを格納する配列
    Dim arrField As Variant        ' レコードファイルのフィールドデータを格納する配列
    Dim strLine As String          ' TSVファイルから読み込んだ1行の文字列を格納する変数
    Dim strField As String         ' レコードファイルから読み込んだ最終行の文字列を格納する変数
    Dim strFile As String          ' 処理対象のファイル名を格納する変数
    Dim i As Long, j As Long, r As Long ' ループ処理用のカウンタ変数
    Dim blnFound As Boolean        ' レコードのキーがテーブル配列内で見つかったかどうかを示すフラグ
    Dim blnTableLoaded As Boolean  ' テーブル配列(arrTable)が初期化されたかを追跡するフラグ

    '--- 事前準備 ---
    ' 指定されたフォルダ(strFolder)が存在しない場合は、エラーとせず処理を終了する
    If Dir(strFolder, vbDirectory) = "" Then Exit Sub
    
    ' エラーハンドラを設定（Goto HdlErr1）。テーブルファイル読み込み中のエラーを捕捉する
    On Error GoTo HdlErr1
    ' Excelのステータスバーに現在の処理内容を表示する
    Application.StatusBar = "「" & strTable & "」テーブルのデータを削除しています。"

    ' 指定されたテーブル名(strTable)の範囲にデータが存在するかどうかを確認する
    ' CountA関数は空白でないセルの数を返すため、0でなければデータが存在すると判断
    If WorksheetFunction.CountA(Range(strTable)) <> 0 Then
        ' テーブルにデータが存在する場合、その行全体を削除する
        Range(strTable).Delete
    End If
    
    '--- 処理速度向上のための設定 ---
    ' テーブルが存在するシートの全セルに対して、テキストの折り返し表示を無効にする
    ' これにより、セルへの書き込み速度が向上する
    With Worksheets(Range(strTable).Parent.Name)
        .Cells.WrapText = False
    End With
    ' テーブル範囲の書式（罫線、色など）をすべてクリアする
    ' これも書き込み速度の向上に寄与する
    Range(strTable).ClearFormats

    '--- 1. テーブルファイルが存在すればテーブル配列に読み込む ---
    blnTableLoaded = False ' テーブル配列がまだ読み込まれていないことを示す
    ' データベースフォルダ内に "Table.TSV" ファイルが存在するか確認する
    If Dir(strFolder & "\" & "Table.TSV") <> "" Then
        ' ステータスバーに処理内容を表示
        Application.StatusBar = "「" & strTable & "」テーブルにテーブルファイルを読み込んでいます。"
        ' "Table.TSV" を読み取り専用（Input）で開く。ファイル番号は1番
        Open strFolder & "\" & "Table.TSV" For Input As #1
        i = 0 ' 行カウンタを初期化
        ' ファイルの終端(End Of File)に達するまでループ処理
        Do Until EOF(1)
            ' ファイルから1行を読み取り、strLineに格納
            Line Input #1, strLine
            ' 読み込んだ行が空行でない場合のみ処理を実行
            If strLine <> "" Then
                ' 読み込んだ行(strLine)をタブ文字(vbTab)で分割し、配列arrLineに格納
                arrLine = Split(strLine, vbTab)
                ' 最初の行(i=0)の場合
                If i = 0 Then
                    ' テーブル配列(arrTable)を初期化。列数を行数、行数を列数として定義（列: UBound(arrLine), 行: 0）
                    ReDim arrTable(UBound(arrLine), 0)
                Else
                    ' 2行目以降は、列数を維持したまま行数を1つ増やす (Preserveで既存のデータを保持)
                    ReDim Preserve arrTable(UBound(arrLine), i)
                End If
                ' 分割した各フィールドのデータをテーブル配列に格納するループ
                For j = 0 To UBound(arrLine)
                    arrTable(j, i) = arrLine(j) ' arrTableの j列, i行 にデータを格納
                Next
                ' 行カウンタをインクリメント
                i = i + 1
            End If
        Loop
        ' ファイルを閉じる
        Close #1
        ' 1行以上読み込まれた場合、テーブル配列がロードされたと判断しフラグを立てる
        If i > 0 Then blnTableLoaded = True
    End If

    '--- 2. レコードファイルをテーブル配列に書き込む ---
    ' ステータスバーに処理内容を表示
    Application.StatusBar = "「" & strTable & "」テーブルのレコードを処理しています。"
    ' エラーハンドラをHdlErr2に切り替え。レコードファイル処理中のエラーを捕捉する
    On Error GoTo HdlErr2
    ' Dir関数でフォルダ内の最初のTSVファイル名を取得
    strFile = Dir(strFolder & "\" & "*.TSV")
    ' フォルダ内にTSVファイルがなくなるまでループ
    Do While strFile <> ""
        ' ファイル名が"Table.TSV"、または名前に"("を含む（コピーファイルなど）場合は処理をスキップ
        If strFile = "Table.TSV" Or InStr(strFile, "(") > 0 Then GoTo Skip

        ' レコードファイルを読み取り専用で開く
        Open strFolder & "\" & strFile For Input As #1
        strField = "" ' 変数を初期化
        ' ファイルの最後まで1行ずつ読み進める（結果的に最終行のみがstrFieldに残る）
        Do Until EOF(1)
            Line Input #1, strField
        Loop
        ' ファイルを閉じる
        Close #1

        blnFound = False ' 一致するキーが見つかったかどうかのフラグをリセット
        ' ファイル名からキーを生成（拡張子".TSV"を取り除く）
        Dim strKeyFromFile As String
        strKeyFromFile = Left(strFile, InStr(strFile, ".") - 1)

        ' テーブル配列が既に読み込まれている（Table.TSVが存在した）場合のみ、キーの検索を行う
        If blnTableLoaded Then
            ' テーブル配列の全行をループ（UBound(arrTable, 2)は行の最大インデックス）
            For r = 0 To UBound(arrTable, 2)
                ' 削除フラグ "__DELETE__" が立っていない行のみを対象とする
                If arrTable(0, r) <> "__DELETE__" Then
                    ' テーブル配列内のキーを生成するための配列を準備
                    Dim arrKeyParts() As String
                    ReDim arrKeyParts(lngKeys - 1) ' lngKeysはキーを構成する列数（事前に定義されている想定）
                    ' キーを構成する列数分ループ
                    For j = 0 To lngKeys - 1
                        ' 各キー列の値を文字列として配列に格納
                        arrKeyParts(j) = CStr(arrTable(j, r))
                    Next
                    ' キー配列の要素を"_"で連結し、単一のキー文字列を生成
                    Dim strKeyInArray As String
                    strKeyInArray = Join(arrKeyParts, "_")
                    
                    ' 配列から生成したキーとファイル名から生成したキーが一致するか評価
                    If strKeyInArray = strKeyFromFile Then
                        blnFound = True ' 一致するキーが見つかったことを示すフラグを立てる
                        ' レコードファイルの最終行が空（タブ文字を削除して評価）の場合、削除とみなす
                        If Replace(strField, vbTab, "") = "" Then
                            ' 削除フラグとして"__DELETE__"を最初の列に設定
                            arrTable(0, r) = "__DELETE__"
                        Else
                            ' レコードファイルにデータがある場合、更新処理を行う
                            ' 最終行をタブで分割し、フィールドデータを配列に格納
                            arrField = Split(strField, vbTab)
                            ' フィールドデータの数だけループ
                            For j = 0 To UBound(arrField)
                                ' 配列の範囲を超えないようにチェックしながら、データを上書き
                                ' lngKeysはキー列の数なので、データはlngKeys列目から始まる
                                If (lngKeys + j) <= UBound(arrTable, 1) Then
                                    arrTable(lngKeys + j, r) = arrField(j)
                                End If
                            Next
                            ' 最終列にレコードファイルの最終更新日時を記録
                            arrTable(UBound(arrTable, 1), r) = FileDateTime(strFolder & "\" & strFile)
                        End If
                        ' 該当キーの処理が完了したため、行のループを抜ける
                        Exit For
                    End If
                End If
            Next
        End If

        ' 一致するキーが見つからず(Not blnFound)、かつレコードが空でない場合、新しい行として追加する
        If Not blnFound And Replace(strField, vbTab, "") <> "" Then
            ' 新しい行のインデックスを格納する変数
            Dim lngNewRow As Long
            ' ファイル名から生成したキーを"_"で分割し、キー配列を生成
            Dim arrKeyFromFile As Variant
            arrKeyFromFile = Split(strKeyFromFile, "_")
            ' レコードファイルの最終行をタブで分割し、フィールド配列を生成
            arrField = Split(strField, vbTab)
            
            ' テーブル配列がまだ作成されていない場合（Table.TSVがなく、これが最初のレコード）
            If Not blnTableLoaded Then
                ' 配列を新規に作成する
                Dim lngCols As Long
                ' シート上のテーブル定義から列数を取得
                lngCols = Range(strTable).Columns.Count
                ' 取得した列数で、1行だけのテーブル配列を初期化
                ReDim arrTable(lngCols - 1, 0)
                lngNewRow = 0 ' 新しい行のインデックスは0
                blnTableLoaded = True ' 配列が作成されたことを示すフラグを立てる
            Else
                ' 既存のテーブル配列に新しい行を追加
                ' 新しい行のインデックスは現在の最終行インデックス+1
                lngNewRow = UBound(arrTable, 2) + 1
                ' 既存のデータを保持(Preserve)したまま、行を1つ追加
                ReDim Preserve arrTable(UBound(arrTable, 1), lngNewRow)
            End If

            '--- 新しく追加した行にデータを格納 ---
            ' キー配列のデータをテーブル配列のキー列に格納
            For j = 0 To UBound(arrKeyFromFile)
                If j <= UBound(arrTable, 1) Then arrTable(j, lngNewRow) = arrKeyFromFile(j)
            Next
            ' フィールド配列のデータをテーブル配列のデータ列に格納
            For j = 0 To UBound(arrField)
                If (lngKeys + j) <= UBound(arrTable, 1) Then arrTable(lngKeys + j, lngNewRow) = arrField(j)
            Next
            ' 最終列にレコードファイルの最終更新日時を記録
            arrTable(UBound(arrTable, 1), lngNewRow) = FileDateTime(strFolder & "\" & strFile)
        End If

Skip: ' ファイルをスキップする場合のジャンプ先ラベル
        ' Dir関数に引数を指定せずに再度呼び出し、同じフォルダ内の次のTSVファイルを取得
        strFile = Dir()
    Loop

    '--- 3. 処理済みの配列をテーブルに書き込む ---
    ' ステータスバーに処理内容を表示
    Application.StatusBar = "「" & strTable & "」テーブルにデータを書き込んでいます。"
    ' もし一度もデータが読み込まれなかった場合(Table.TSVもレコードもなし)、書き込み処理をスキップして終了処理へ
    If Not blnTableLoaded Then GoTo Cleanup

    ' シートに書き込むための最終的な出力用配列を宣言
    Dim arrOutput() As Variant
    ' 出力用配列の行・列カウンタを宣言
    Dim lngOutputRow As Long, lngOutputCol As Long
    lngOutputRow = -1 ' 出力用配列の行カウンタを-1で初期化

    ' 処理済みのテーブル配列(arrTable)の全行をループ
    For r = 0 To UBound(arrTable, 2)
        ' 削除フラグ "__DELETE__" が立っていない行のみを出力対象とする
        If arrTable(0, r) <> "__DELETE__" Then
            ' 出力用配列の行カウンタをインクリメント
            lngOutputRow = lngOutputRow + 1
            ' 最初の有効な行が見つかった場合
            If lngOutputRow = 0 Then
                ' 出力用配列を初期化
                ReDim arrOutput(UBound(arrTable, 1), 0)
            Else
                ' 2行目以降は、既存のデータを保持しつつ行を1つ追加
                ReDim Preserve arrOutput(UBound(arrTable, 1), lngOutputRow)
            End If
            ' 1行分のデータをarrTableからarrOutputにコピーするループ
            For lngOutputCol = 0 To UBound(arrTable, 1)
                arrOutput(lngOutputCol, lngOutputRow) = arrTable(lngOutputCol, r)
            Next
        End If
    Next

    ' 有効な行が1行以上存在した場合（lngOutputRowが0以上になった場合）
    If lngOutputRow >= 0 Then
        ' VBA配列は(列, 行)だが、シートへの書き込みは(行, 列)で行うため、WorksheetFunction.Transposeで行と列を入れ替える
        arrOutput = WorksheetFunction.Transpose(arrOutput)
        ' 入れ替えた配列を、指定テーブルの左上セルを基点に一括で書き込む
        ' Resizeで行数と列数を指定する
        Range(strTable).Resize(UBound(arrOutput, 1), UBound(arrOutput, 2)).Value = arrOutput
        ' 値を値として再代入する。これにより、数値が文字列として扱われるなどの問題を回避し、書式を確定させる
        Range(strTable).Resize(UBound(arrOutput, 1), UBound(arrOutput, 2)).Value = Range(strTable).Resize(UBound(arrOutput, 1), UBound(arrOutput, 2)).Value
    End If

Cleanup: ' 終了処理のジャンプ先ラベル
    ' Excelのステータスバー表示をデフォルトに戻す
    Application.StatusBar = False
    ' プロシージャを正常終了
    Exit Sub

HdlErr1: ' テーブルファイル読み込み中のエラーハンドラ
    ' エラーメッセージをダイアログボックスで表示
    MsgBox "テーブルファイルの読み込み中にエラーが発生しました。", vbCritical
    ' ステータスバーをリセット
    Application.StatusBar = False
    ' 開いている可能性のあるファイルをすべて閉じる
    Close
    ' プロシージャを終了
    Exit Sub

HdlErr2: ' レコードファイル処理中のエラーハンドラ
    ' ファイル名が空の場合は一般的な名称に置き換える
    If strFile = "" Then strFile = "レコードファイル"
    ' エラーが発生したファイル名をメッセージに含めて表示
    MsgBox strFile & "の処理中にエラーが発生しました。", vbCritical
    ' ステータスバーをリセット
    Application.StatusBar = False
    ' 開いている可能性のあるファイルをすべて閉じる
    Close
End Sub

マクロの組み込み

データ共有マクロの起動は、次のようなイベントプロシージャでおこないます。

ThisWorkbookモジュール

ワークブックを開いた際に、データーベースのデータを読み込んだ後、書き込みを行います。
書き込みを行うことで、レコードファイルが削除されるので以降の読み込み速度を向上できます。

'ワークブックを開いた場合に処理を行う
Private Sub Workbook_Open()
   'データベースのデータを読み込む
   Call ReadTable(Range("データベースフォルダ").Value, "テーブル", 1)

   'テーブルファイルのファイルスタンプが昨日以前の場合
   If FileDateTime(Range("データベースフォルダ").Value & "\" & "Table.TSV") < Date Then
      'データベースへの書き込みを行う
      Call WriteTable(Range("データベースフォルダ").Value, "テーブル", 2)
   End If
End Sub

シートモジュール

ワークシートに変更が加えられた際に、レコードファイルへの書き込みを行います。
書き込みを行うと、読み込みが自動的に行われるので、ファイルへの書き込みを確認できます。

'ワークシートに変更が加えられた場合に処理を行う
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Long, s As Long

'ターゲット行列番号をテーブル行列番号に変換する
r = Target.Row - Range("テーブル").Row + 1
s = Target.Column - Range("テーブル").Column + 1

'テーブル行・列番号が入力範囲外の場合は終了する
If r < 1 Or Range("テーブル").Rows.Count < r Then Exit Sub
If s <= 1 Or Range("テーブル").Columns.Count <= s Then Exit Sub
	
'データをレコードファイルに書き込む
Call WriteRecord(Range("データベースフォルダ").Value, "テーブル", r, 1)
End Sub

マクロを組み込んだエクセルファイル自体は、「読み取り専用」で使用することをおすすめします。外部データベース以外にデータを保存しないようにできるからです。エクセルファイルの保存時に「書き込みパスワード」を設定することで実現できます。

当サイトで紹介している「VA電話メモ」および「VA事件データベース」には、データ共有マクロがクラスで組み込んであります。

細部については、各サンプルファイルを参照してください。

関連記事