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

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

ただし、デスクトップ版のエクセルでは正常に機能しないことも多いようです。特に、VBAを使ったファイルを共同編集することができない場合が少なくありません（当方の環境によるものかもしれません。）

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

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

なお、SharePoint上に置いてもセキュリティ上問題のないデータであれば、エクセルよりもMicrosoftListなどを使ったほうが便利です。

CSVファイルを使ったデータ共有の原理

ユーザーがエクセルファイルにデータを入力した際には、そのテーブルのレコード（行）データをレコードファイル（TSVファイル）に書き込みます。（CSVファイルはカンマを区切り文字に使うのが一般的ですが、データに「,」が使われることが考えられるため区切り文字にタブを使ったTSVファイルを使用しています。）

排他性をもたせるため、レコードファイルのファイル名をテーブルのキー列にしています。（図のように「キー」にユーザー名を加えることができば、排他性がより高まります。）
また、テーブルの更新日時とタイムスタンプを比較することで、他の人が変更したデータを上書きする場合はメッセージが表示されるようにしています。（他の人が変更したデータを選択した場合は、レコードファイルの内容をテーブルのレコードに上書きします。）

速度を向上させるため、テーブル全体のデータはテーブルファイルに保存しています。エクセルを起動した際には、テーブルファイルとすべてのレコードファイルからデータの読込を行います。（その日のレコードファイルの数が増えると読込に時間がかかるようになります。その場合は、データの読込が終わってからテーブル全体をテーブルファイルに書込み、すべてのレコードファイルを削除するようにします。

注意：プログラムの制約上、レコードが1つ以下の場合は読込ができません。（対応も可能ですが、実用上は問題ないので放置してあります。）

データ共有マクロ

CSVファイルを利用した外部データベースを使うためには、「WriteRecord」、「ReadRecord」、「WriteTable」および「ReadTable」の4つのプロシージャが必要となります。

WriteRecord

テーブルレコードをレコードファイルに書きこみます。

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

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

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

'ステータスバーを表示する
Application.StatusBar = "レコードファイルに書き込んでいます。"
    
'ファイル名を把握する
'TextJoin関数を使ってキー列の値をアンダーバーで区切って生成します。
'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
    'レコードファイルのデータを読み込む
    Call TSV.ReadRecord(strFolder, strTable, r, lngKeys)
    
    '終了する
    Exit Sub
End If

Continue:

'レコードファイルを出力モードで開く
'ファイルが存在しない場合は新規に作成されます。
Open strFolder & "\" & strFile For Output As #1

'フィールド列の値をタブで区切ってフィールド文字列を生成する
'キー列の次の列から「更新日時」の手前列までのデータを取り込みます。
'TextJoin関数を使ってキー列の値をタブで区切って生成します。
'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

'テーブル行のタイムスタンプを修正する
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

'メッセージを表示する
If MsgBox("他の人のデータを読み込みますか？", vbYesNo) = vbNo Then
    '処理を終了する
    Exit Sub
End If

'ステータスバーを表示する
Application.StatusBar = "レコードファイルを読み込んでいます。"
    
'ファイル名を把握する
'TextJoin関数を使ってキー列の値をアンダーバーで区切って生成します。
'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).Value = Range(strTable).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 = "テーブルファイルにデータを書き込んでいます。"

'テーブルファイルを出力モードで開く
'ファイルが存在しない場合は新規に作成されます。
Open strFolder & "\" & "Table.TSV" For Output As #1
        
'テーブルのすべての行を繰り返す
For r = 1 To Range(strTable).Rows.Count
    'テーブルの行の文字列をテーブルファイルに書き込む
    '文字列はTextJoin関数を使って行全体のセルの値をタブで区切って生成します。
    '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 = "レコードファイルを削除しています。"
    
'データベース内のファイルを検索する
Dim strFile
strFile = Dir(strFolder & "\" & "*.TSV")

'ファイルが存在する間
Do While strFile <> ""
    'ファイルがテーブルファイルでなく、コピーファイルでもない場合
    If strFile <> "Table.TSV" And InStr(strFile, "(") = 0 Then
        'ファイルを削除する
        Kill strFolder & "\" & strFile
    End If
    '次のファイルを読み込む
    strFile = Dir()
Loop

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

HdlErr:
'エラーメッセージを表示する
MsgBox "テーブルからデータベースへの書き込みができませんでした。", vbExclamation

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

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

ReadTable

データベースから全てのデータを読み込んでテーブルを書き換えます。

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

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

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

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

'テーブルにデータがあれば削除する
If WorksheetFunction.CountA(Range(strTable)) <> 0 Then Range(strTable).Delete

'ステータスバーを表示する
Application.StatusBar = "テーブルファイルを読み込んでいます。"
    
'テーブルファイルを入力モードで開く
Open strFolder & "\" & "Table.TSV" For Input As #1

'テーブルが存在するワークシートが対象
With Worksheets(Range(strTable).Parent.Name)
    'テーブル外のシートにライン文字列を書きこむ
    'テーブル内に書きこむと処理が遅いので一旦テーブル外に書き込みます。
    i = Range(strTable).Row + Range(strTable).Rows.Count
    j = Range(strTable).Column

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

        'ライン文字列をテーブル外のシートに書き込む
        'https://daitaideit.com/vba-char-split/
        Range(.Cells(i, j), .Cells(i, j + Range(strTable).Columns.Count - 1)) = Split(strLine, vbTab)

        '次の行に移動する
        i = i + 1
    Loop

    'シート上の値をテーブル内にカットアンドペーストする
    Range(.Cells(Range(strTable).Row + Range(strTable).Rows.Count, j), .Cells(i, j + Range(strTable).Columns.Count - 1)).Cut _
        Destination:=Range(strTable)(1, 1)

    'テーブルの最終行が空欄の場合は削除する
    If WorksheetFunction.CountA(Range(strTable).Rows(Range(strTable).Rows.Count)) = 0 Then
        Range(strTable).Rows(Range(strTable).Rows.Count).Delete
    End If
End With

'テーブルファイルを閉じる
Close #1
        
'ステータスバーを表示する
Application.StatusBar = "レコードファイルを読み込んでいます。"
    
'データベースフォルダからファイル名を読み込む
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
            
    'すべてのキー列を繰り返す
    blnMatch = True
    For x = 1 To lngKeys
        'ファイル名のキーデータと一致する値がない場合
        If WorksheetFunction.CountIf(Range(strTable).Columns(x), Split(Left(strFile, _
            InStr(strFile, ".") - 1), "_")(x - 1)) = 0 Then
            'キーが一致する行をなしに設定する
            blnMatch = False
            Exit For
        End If
    Next
    
    'キーが一致する行がある場合
    If blnMatch = True Then
        'テーブルのすべての行を繰り返す
        For r = 1 To Range(strTable).Rows.Count
            '行のキーデータがファイル名と一致する場合
            'ファイル名はTextJoin関数を使ってキー列の値をアンダーバーで区切って生成します。
            '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
            End If
        Next
    'キーが一致する行がない場合
    Else
        '最終行の次の行を把握する
        r = Range(strTable).Rows.Count + 1
        
        'フィールド文字列がある場合
        If Replace(strField, vbTab, "") <> "" Then
            'ファイル名をキー列に書き込む
            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)
        End If
    End If
Skip:
    '次のファイルを読み込む
    strFile = Dir()
Loop
        
'セルの数値を入力し直す
'これを行わないと日付の書式が乱れます。
Range(strTable).Value = Range(strTable).Value

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

HdlErr:
'エラーメッセージを表示する
MsgBox "データベースからテーブルへの読み込みができませんでした。", vbExclamation

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

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

マクロの組み込み

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

ThisWorkbookモジュール

'ワークブックを開いた場合に処理を行う
Private Sub Workbook_Open()
   'データベースのデータを読み込む
    Call TSV.ReadTable(Range("データベースフォルダ").Value, "テーブル", 1)
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 TSV.WriteRecord(Sheet91.Range("データベースフォルダ").Value, "テーブル", r, 1)
End If
End Sub

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

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

関連記事