OneDriveを使わずにファイルを共同編集する

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

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

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

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

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

データ共有マクロ

WriteRecord

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

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

Sub WriteRecord(strFolder, strTable, r, lngKeys)
'テーブルレコードをレコードファイルに書きこみます。

'エラー処理を設定する
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

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

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

Sub ReadRecord(strFolder, strTable, r, lngKeys)
'テーブルレコードをレコードファイルから読み込みます。

'エラー処理を設定する
On Error GoTo HdlErr

'ステータスバーを表示する
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

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

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

Sub WriteTable(strFolder, strTable, lngKeys)
'テーブル全体をテーブルファイルに書き込んで、レコードファイルを削除します。

'エラー処理を設定する
On Error GoTo HdlErr
    
'ステータスバーを表示する
Application.StatusBar = "「" & strTable & "」テーブルをテーブルファイルに書き込んでいます。"

'テーブルファイルを出力モードで開く
'ファイルが存在しない場合は新規に作成されます。
Open strFolder & "\" & "Table.TSV" For Output As #1
        
'テーブルのすべての行を繰り返す
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 Then
            'レコードファイルを削除する
            Kill strFolder & "\" & strFile
        End If
    End If
    '次のファイルを読み込む
    strFile = Dir()
Loop

'ステータスバーを解除する
Application.StatusBar = False
Exit Sub

HdlErr:
'エラーメッセージを表示する
MsgBox "「" & strTable & "」テーブルからテーブルファイルへの書き込みができませんでした。", vbExclamation

'ステータスバーを解除する
Application.StatusBar = False

'すべてのファイルを閉じる
Close
End Sub

ReadTable

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

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

Sub ReadTable(strFolder, strTable, lngKeys)
'データベースから全てのデータを読み込んでテーブルを書き換えます。

'エラー処理を設定する
On Error GoTo HdlErr

'ステータスバーを表示する
Application.StatusBar = "「" & strTable & "」テーブルのデータを削除しています。"

'テーブルにデータがあれば削除する
'データを削除しても書式は残ります。
If WorksheetFunction.CountA(Range(strTable)) <> 0 Then Range(strTable).Delete

'シートの折り返し表示を解除する
'書き込み速度を向上させるための処理です。
'https://vba-assets.net/array-to-table/
With Worksheets(Range(strTable).Parent.Name)
    .Cells.WrapText = False
End With

'テーブルの書式を解除する
'書き込み速度を向上させるための処理です。
'https://vba-assets.net/array-to-table/
Range(strTable).ClearFormats

'ステータスバーを表示する
Application.StatusBar = "「" & strTable & "」テーブルにテーブルファイルを読み込んでいます。"

'レコードファイルが存在しない場合はスキップする
If Dir(strFolder & "\" & "Table.TSV") = "" Then GoTo Continue
    
'テーブルファイルを入力モードで開く
Open strFolder & "\" & "Table.TSV" For Input As #1

'テーブルファイルの終端まで繰り返す
i = 0
Do Until EOF(1)
    'ライン文字列を読み込む
    'http://officetanaka.net/excel/vba/file/file08b.htm
    Dim strLine
    Line Input #1, strLine

    'ライン文字列をライン配列に書き込む
    'https://daitaideit.com/vba-char-split/
    Dim arrLine
    arrLine = Split(strLine, vbTab)
    
    'ライン配列をテーブル配列に追加する
    '文字列型からバリアント型に変換されますため、セルの数値の入れ直しは不要です。
    Dim arrTable()
    ReDim Preserve arrTable(UBound(arrLine), i)
    For j = 0 To UBound(arrLine)
        arrTable(j, i) = arrLine(j)
    Next

    '次のレコードに移動する
    i = i + 1
Loop
    
'テーブルファイルを閉じる
Close #1

'テーブル配列の行列を入れ替える
'Transposeの出力は、配列が1から始まるように作成されます。
'https://excel-ubara.com/excelvba4/EXCEL258.html
'レコードが1つしかない場合は1次元配列になってエラーが発生します。
arrTable = WorksheetFunction.Transpose(arrTable)

'テーブル配列をテーブルに書き込む
Range(strTable).Resize(UBound(arrTable, 1)) = arrTable

Continue:
'ステータスバーを表示する
Application.StatusBar = "「" & strTable & "」テーブルにレコードファイルを読み込んでいます。"
    
'データベースフォルダからファイル名を読み込む
Dim strFile
strFile = Dir(strFolder & "\" & "*.TSV")

'レコードファイルが存在する間
Do While strFile <> ""
    'テーブルファイルまたはコピーファイルの場合はスキップする
    If strFile = "Table.TSV" Or InStr(strFile, "(") > 0 Then GoTo Skip
    
    'レコードファイルを入力モードで開く
    Open strFolder & "\" & strFile For Input As #1
        
    'フィールド文字列を読み込む
    'http://officetanaka.net/excel/vba/error/execution_error/error_62.htm
    Dim strField
    Do Until EOF(1)
        Line Input #1, strField
    Loop
    
    'レコードファイルを閉じる
    Close #1
            
    'テーブルのすべての行を繰り返す
    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
        If WorksheetFunction.TextJoin("_", False, Range(Range(strTable)(r, 1), Range(strTable)(r, lngKeys))) _
            & ".TSV" = strFile Then
            'フィールド文字列がない場合
            If Replace(strField, vbTab, "") = "" Then
                'テーブルの行を削除する
                Range(strTable).Rows(r).Delete
            
            'フィールド文字列がある場合
            Else
                'フィールド文字列をキー列以降に書き込む
                Range(Range(strTable)(r, lngKeys + 1), Range(strTable)(r, Range(strTable).Columns.Count - 1)) _
                    = Split(strField, vbTab)

                'タイムスタンプを最終列に書き込む
                Range(strTable)(r, Range(strTable).Columns.Count) = FileDateTime(strFolder & "\" & strFile)
            End If
            
            'セルの値を入力しなおす
            'これを行わないと数値が文字列のままになります。
            Range(strTable).Rows(r).Value = Range(strTable).Rows(r).Value
            
            '処理をスキップする
            GoTo Skip
        End If
    Next

    'フィールド文字列がない場合は処理をスキップする
    If Replace(strField, vbTab, "") = "" Then GoTo Skip
    
    'テーブルにデータがない場合
    If Range(strTable)(1, 1) = "" Then
        '入力行を1に設定する
        r = 1
    'テーブルにデータがある場合
    Else
        '最終行の次の行を入力行に設定する
        r = Range(strTable).Rows.Count + 1
    End If
    
    'ファイル名をキー列に書き込む
    Range(Range(strTable)(r, 1), Range(strTable)(r, lngKeys)) = _
        Split(Left(strFile, InStr(strFile, ".") - 1), "_")

    'フィールド文字列をキー列以降の列に書き込む
    Range(Range(strTable)(r, lngKeys + 1), Range(strTable)(r, Range(strTable).Columns.Count - 1)) = _
        Split(strField, vbTab)

    'タイムスタンプを最終列に書き込む
    Range(strTable)(r, Range(strTable).Columns.Count) = FileDateTime(strFolder & "\" & strFile)
    
    'セルの値を入力しなおす
    'これを行わないと数値が文字列のままになります。
    Range(strTable).Rows(r).Value = Range(strTable).Rows(r).Value
Skip:
    '次のファイルを読み込む
    strFile = Dir()
Loop

'ステータスバーを解除する
Application.StatusBar = False
Exit Sub

HdlErr:
'エラーメッセージを表示する
MsgBox "「" & strTable & "」テーブルへのファイルの読み込みができませんでした。", vbExclamation

'ステータスバーを解除する
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 If
End Sub

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

当サイトで紹介している「VA電話メモ」には、データ共有マクロがクラスで組み込まれています。

細部については、こちらの記事のサンプルファイルを参照してください。

関連記事