EXCEL VBA で既存のテーブルにネットワークドライブ上の Workbook からデータを追記する

　前回の記事ではフォルダーから一括してデータを読み込む方法を紹介した．今回は月次の更新ファイルを読み込んで既存のテーブルにデータを追記する方法を紹介する．

　既に読み込んだファイルは拒否したい．監査としてのワークシートが必要だ．リレーショナルデータベースならデータの一意制約から可能だが，EXCEL では自前で作る必要がある．

　色々と挑戦しがいのある課題であった．

ネットワークドライブ上のファイル選択

ユーザーにファイルを選ばせるなら GetOpenFilename 関数，なのだが…

　Application.GetOpenFilename 関数を使うと，ダイアログを開いてユーザーにファイルを選ばせることができる．戻り値は Variant 型で宣言しておき，ユーザーの行動を完全に捕捉する．

　ローカルドライブにあるファイルなら，下記のコードで対応できる．

Dim myPath    As Variant
myPath = Application.GetOpenFilename("Excel, *.xls?, , , , False")
If myPath = False Then Exit Sub

ネットワークドライブ上のファイルパスを取得するには Windows Scripting Host が必要

　最初からつまづきそうになる．実際にはユーザーインターフェースではネットワークを選ぶことができない．ローカルドライブ上では簡単に取得できるファイルパスが，ネットワーク上に変わるだけで難易度が上がる．

　ネットワーク上のファイルパスを取得するには Windows Scripting Host が必要になる．Object 型の変数を宣言してインスタンスを生成する．

　筆者の環境だとネットワーク上のファイルパスは \\192.168.xxx.yy\ で始まる文字列である．取得元になるファイル群と取得先である自分自身とが同じディレクトリにあると，話が早い．

Dim myObj   As Object
Set myObj = CreateObject("WScript.Shell")
With myObj
    .Currentdirectory = ThisWorkbook.Path
End With
Dim myPath  As Variant
myPath = Application.GetOpenFilename("Excel, *.xls?, , , , False")
If myPath = False Then Exit Sub

Workbooks.Open で Workbook を取得する

　GetOpenFilename 関数で得たファイルパスを引数として渡し，Workbook オブジェクトを取得する．3 番目の引数は読み取り専用を表している．

Dim myWB    As Workbook
Set myWB = Workbooks.Open(myPath, , True)

監査テーブル

監査テーブルのあるワークシートを取得する

　監査テーブル，またはログともいうが，これはユーザーの指定したファイルが既に取得済みであるか否かを監査する役割を果たす．具体的には，ユーザーの指定したファイル名がワークシートに存在するか検索し，存在すれば処理を中断する．存在しなければ入力処理へと進む．

　まずは監査テーブルのあるワークシートを取得する．Sheet3 にあるものとする．

Dim mySh    As Worksheet
Dim myRng   As Range
Set mySh = ThisWorkbook.Worksheets("Sheet3")
Set myRng = mySh.Range("A1").CurrentRegion

監査テーブルを検索する

　監査テーブルと言っても，ファイル名とファイル作成日からなるテーブルに過ぎない．このテーブルを検索し，ユーザーの指定したファイル名が存在するか否かで処理継続の可否を決める．それだけである．筆者のスキルではこれ以上の機能は実装できない．

　下記コードの Else 節以降は監査テーブルにユーザーの指定したファイル名が見つかった場合，つまり既にファイルが取り込み済みである場合の処理である．つまり，ユーザーの指定したファイルを閉じてプロシージャを終了している．本来ならファイル作成日の一致の是非も判定基準に加えるべきだが，割愛する．

Dim mySh    As Worksheet
Dim myRng   As Range
Set mySh = ThisWorkbook.Worksheets("Sheet3")
Set myRng = mySh.Range("A1").CurrentRegion
Set myRng = myRng.Find(what:=myWB.Name)
If myRng Is Nothing Then
    
Else
    myWB.Close
    Exit Sub
End If

　ここから先，自分でもなぜこんなコードを書いたのか思い出せない．が，意図通りに動いている．前半は監査テーブルにファイル名と作成日を追記しており，後半は配列に取得してからテーブルにデータを追記している．

FileSystemObject を使うのはファイル作成日を参照するため

　フォルダ内の Files コレクションを取得するには， FileSystemObect に GetFolder() 関数を適用して Folder オブジェクトを取得し，Files プロパティを適用する．ここで FileSystemObject を使うのはファイル作成日を参照するためであり，Workbook オブジェクトにはそのようなメタデータを取得するプロパティは存在しない．

Dim myFSO   As Scripting.FileSystemObject
Set myFSO = New Scripting.FileSystemObject
Dim myFiles As Scripting.Files
Dim myFile  As Scripting.File
Set myFiles = myFSO.GetFolder(ThisWorkbook.Path).Files

監査テーブルへの書き込み

　Files コレクションをループして File オブジェクトを取得する．File.Name と Workbook.Name が一致した場合にファイル名と作成日を書き込む．繰り返すが，ファイル作成日は FileSystemObject からでないと参照できない．

Dim mySh    As Worksheet
Dim myRng   As Range
Set mySh = ThisWorkbook.Worksheets("Sheet3")
Set myRng = mySh.Range("A1").CurrentRegion
Set myRng = myRng.Find(what:=myWB.Name)
If myRng Is Nothing Then
    
    For Each myFile In myFiles
        If myFile.Name = myWB.Name Then
            Set myRng = mySh.Range("A1").CurrentRegion
            Set myRng = myRng.Offset(myRng.Rows.Count)Resize(1, 2)
            myRng.Cells(1, 1) = myWB.Name
            myRng.Cells(1, 2) = myFile.DateCreated
            
        End If
    Next myFile
Else
    myWB.Close
    Exit Sub
End If

データの取得からテーブルへの書き込みまで

Worksheets コレクションをループして Worksheet オブジェクトを取得

　9 行目から 11 行目で Worksheets コレクションをループして Worksheet オブジェクトを取得する．このあたりの処理はよく見かけるものである．

If myRng Is Nothing Then
    
    For Each myFile In myFiles
        If myFile.Name = myWB.Name Then
            Set myRng = mySh.Range("A1").CurrentRegion
            Set myRng = myRng.Offset(myRng.Rows.Count)Resize(1, 2)
            myRng.Cells(1, 1) = myWB.Name
            myRng.Cells(1, 2) = myFile.DateCreated
            For Each mySh In myWB.Worksheets
                
            Next mySh
        End If
    Next myFile
Else
    myWB.Close
    Exit Sub
End If

Range オブジェクトを取得して動的配列に代入

　必要な変数を宣言して Range オブジェクトを取得し，動的配列に代入していく．このあたりの処理は前回と同様である．

Dim myVar    As Variant
Dim i        As Long
Dim j        As Long
Dim myID()   As String
Dim myName() As String
Dim myDate() As Date
Dim myTest() As Single
Dim myYear() As Long
Dim myMonth()    As Long
Dim myDay()  As Long

If myRng Is Nothing Then
    j = 0
    For Each myFile In myFiles
        If myFile.Name = myWB.Name Then
            Set myRng = mySh.Range("A1").CurrentRegion
            Set myRng = myRng.Offset(myRng.Rows.Count)Resize(1, 2)
            myRng.Cells(1, 1) = myWB.Name
            myRng.Cells(1, 2) = myFile.DateCreated
            For Each mySh In myWB.Worksheets
                Set myRng = Intersect(mySh.Range("A1").CurrentRegion, mySh.Range("A:D"))
                Set myRng = myRng.Resize(myRng.Rows.Count - 1).Offset(1)
                myVar = myRng
                For i = LBound(myVar) to UBound(myVar)
                    Redim Preserve myID(j)
                    Redim Preserve myName(j)
                    Redim Preserve myDate(j)
                    Redim Preserve myTest(j)
                    Redim Preserve myYear(j)
                    Redim Preserve myMonth(j)
                    Redim Preserve myDay(j)
                    myID(j) = myVar(i, 1)
                    myName(j) = myVar(i, 2)
                    myDate(j) = myVar(i, 3)
                    myTest(j) = myVar(i, 4)
                    myYear(j) = myVar(i, 3)
                    myMonth(j) = myVar(i, 3)
                    myDay(j) = myVar(i, 3)
                    j = j + 1
                Next i
            Next mySh
        End If
    Next myFile
    
Else
    myWB.Close
    Exit Sub
End If

テーブルへのデータ追記は ListRows.Add

　テーブルへのデータ追記は行単位で行う．具体的には 50 行目の ListRows.Add で ListRow オブジェクトを取得する．最終的に Range オブジェクトで取得しているが，この方法を見つけた時は，少し感動した．

　51 行目で Array 関数で配列化しているのはワークシートへのアクセス回数を減らしたいためである．ループ 1 回あたり 1 回のアクセスとなっている．

Dim myVar    As Variant
Dim i        As Long
Dim j        As Long
Dim myID()   As String
Dim myName() As String
Dim myDate() As Date
Dim myTest() As Single
Dim myYear() As Long
Dim myMonth()    As Long
Dim myDay()  As Long

Dim myLstObj As ListObject
Dim myArray  As Variant

If myRng Is Nothing Then
    j = 0
    For Each myFile In myFiles
        If myFile.Name = myWB.Name Then
            Set myRng = mySh.Range("A1").CurrentRegion
            Set myRng = myRng.Offset(myRng.Rows.Count)Resize(1, 2)
            myRng.Cells(1, 1) = myWB.Name
            myRng.Cells(1, 2) = myFile.DateCreated
            For Each mySh In myWB.Worksheets
                Set myRng = Intersect(mySh.Range("A1").CurrentRegion, mySh.Range("A:D"))
                Set myRng = myRng.Resize(myRng.Rows.Count - 1).Offset(1)
                myVar = myRng
                For i = LBound(myVar) to UBound(myVar)
                    Redim Preserve myID(j)
                    Redim Preserve myName(j)
                    Redim Preserve myDate(j)
                    Redim Preserve myTest(j)
                    Redim Preserve myYear(j)
                    Redim Preserve myMonth(j)
                    Redim Preserve myDay(j)
                    myID(j) = myVar(i, 1)
                    myName(j) = myVar(i, 2)
                    myDate(j) = myVar(i, 3)
                    myTest(j) = myVar(i, 4)
                    myYear(j) = myVar(i, 3)
                    myMonth(j) = myVar(i, 3)
                    myDay(j) = myVar(i, 3)
                    j = j + 1
                Next i
            Next mySh
        End If
    Next myFile
    Set mySh = Worksheets("Sheet2")
    Set myLstObj = mySh.ListObjects(1)
    For i = LBound(myID) to UBound(myID)
        Set myRng = myLstObj.ListRows.Add.Range
        myArray = Array(myID(i), myName(i), myDate(i), myTest(i), myYear(i), myMonth(i), myDay(i))
        myRng = myArray
    Next i
Else
    myWB.Close
    Exit Sub
End If

　今回の学びはこの部分の記述である．テーブルではない通常の Range オブジェクトに対しては二次元配列を代入して一回の書き込みで処理を終了できるが，テーブルの場合だとそのような方法が思いつかない．ListRow オブジェクトは ListRows.Add として取得する．SQL で言うところの下記のステートメントに該当する．

INSERT INTO Table VALUES(value1, value2, ...)

　この記述では 1 行ずつしかテーブルを拡張できない．BULK INSERT に該当する，何か一括して代入する方法があれば良いのだが．

オブジェクトブラウザーと SQL から見る ListRow オブジェクト

　SQL で頻用するステートメントは SELECT, INSERT, UPDATE, DELETE である．INSERT 以外は WHERE 句とセットでレコードを特定する必要があり，VBA では ListRows.Item(Index) あたりになるだろうか．UPDATE なら Range プロパティを指定して実際に書き換えを行い，DELETE なら LisRow.Delete となるだろう．

ListRows コレクション

MEMBER		Type of Return
Add([Position], [AlwaysInsert])	Function	ListRow
Application	Property	Application
Count	Property	Long
Creator	Property	XlCreator
Item(Index)	Property	ListRow
Parent	Property	Object

ListRow オブジェクト

MEMBER		Type of Return
Application	Property	Application
Creator	Property	XlCreator
Delete	Sub
Index	Property	Long
Parent	Property	Object
Range	Property	Range