LoginSignup
2
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 1 year has passed since last update.

@chem-it-village

Excel-VBA：テーブルデータを別のExcelファイルに転記する

Last updated at Posted at 2024-02-12

0. はじめに

マクロを実行しているExcelファイル(source)のテーブルを、
別のExcelファイル(target)のテーブルに追記する方法についてご紹介します。
image.png

1. 関数の準備

① コピペを実行するための関数を準備します。

CopyTableToOtherExcel
Function CopyTableToOtherExcel(ByVal strSourceSheetName As String, ByVal strSourceTableName As String, _
                                                    ByVal strTargetFilePath As String, _
                                                    ByVal strTargetSheetName As String, ByVal strTargetTableName As String) As Boolean
    '''
    ' マクロを実行しているExcelファイル(source)のテーブルを、別のExcelファイル(target)のテーブルに追記する
    '
    ' Parameters
    ' ------------
    ' strSourceSheetName : String, コピー対象のテーブルが記入されたシートの名前.
    ' strSourceTableName : String, コピー対象のテーブル名.
    ' strTargetFilePath : String, ペースト対象のファイルパス.
    ' strTargetSheetName : String, ペースト対象のテーブルが記入したシートの名前.
    ' strTargetTableName : String, ペースト対象のテーブル名.
    '
    ' Returns
    ' ---------
    ' Boolean (エラー無く実行されればTrue)
    '''
    Dim wsSource As Worksheet
    Dim loSource As ListObject
    Dim rngSourceData As Range
    Dim strSourceID As String
    
    Dim wsTarget As Worksheet
    Dim wbTarget As Workbook
    Dim loTarget As ListObject
    Dim rngTargetData As Range
    Dim intTargetLastRow As Integer
    
    On Error GoTo ErrorHandler
    
    '' (1) コピー対象の情報を取得
    Set wsSource = Worksheets(strSourceSheetName) ' コピー対象のテーブルが記入されたシート
    Set loSource = wsSource.ListObjects(strSourceTableName) ' コピー対象のテーブル
    Set rngSourceData = loSource.DataBodyRange ' コピー対象のテーブル範囲
    
    Debug.Print "a"
    
    '' (2) ペースト先の情報を取得
    Set wbTarget = Workbooks.Open(strTargetFilePath) ' ペースト先のファイル
    Set wsTarget = wbTarget.Sheets(strTargetSheetName) ' ペースト先のシートを
    Set loTarget = wsTarget.ListObjects(strTargetTableName)  'ペースト先のテーブル
    
    '' (3) コピペ
    '' ターゲットのテーブルが空か否かで分岐
    If loTarget.DataBodyRange Is Nothing Then ' 空の場合一番⇒上に貼り付け
        ' コピー
        rngSourceData.Copy
        ' ペースト
        wsTarget.Cells(2, 1).PasteSpecial xlPasteValues ' 値の貼り付け
        ' コピー範囲の選択を解除
        Application.CutCopyMode = False
    Else ' 空でない場合 ⇒ 最終行の一つ下の行に貼り付け
        ' ペースト対象のテーブル範囲を選択
        Set rngTargetData = loTarget.DataBodyRange
        ' ペースト対象の最終行を取得
        intTargetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
        ' コピー
        rngSourceData.Copy
        ' ペースト
        wsTarget.Cells(intTargetLastRow + 1, 1).PasteSpecial xlPasteValues ' 値の貼り付け
    End If
    
    '' (4) ペースト先のファイルを保存して閉じる
    wbTarget.Save
    wbTarget.Close
    
    '' (5) オブジェクトを開放
    Set rngTargetData = Nothing
    Set rngSourceData = Nothing
    Set loTarget = Nothing
    Set loSource = Nothing
    Set wsTarget = Nothing
    Set wsSource = Nothing
    Set wbTarget = Nothing
    Set wbsource = Nothing
    
    
   CopyTableToOtherExcel = True
   Exit Function
   
ErrorHandler:
    ''(6) エラーが発生した場合にFalseを返す
    CopyTableToOtherExcel = False
    MsgBox "コピー中にエラーが発生しました"
End Function

上記の関数では、情報の中身に関係なくデータを追記していくことになります。

一方で実際の運用を考えると、
同じIDのデータを転記する際には上書きを実行したくなることがあります。
上記に対応するため、IDの列を指定して既存のデータの有無を判断したうえで
コピペを実行する関数を追加で用意します。(一度に1つのIDを追記する場合に限ります）

② ということで、同じIDのデータの有無を確認する関数を用意します。

CheckExistenceId
Function CheckExistenceId(ByVal loTarget As ListObject, ByVal intIdColumnIdx As Integer, ByVal varTargetId As Variant) As Boolean
    '''
    ' 同じIDのデータの有無を判定する関数
    ' loTargetのintIdColumnIdx番目のカラムにvarTargetIdが存在しているかを判定
    '
    ' Parameters
    ' ------------
    ' loTarget : IDの有無の判定を行う対象のテーブル
    ' intIdColumnIdx : IDの有無の判定を行う対象のカラム番号
    ' varTargetId : 存在を確認するID
    '
    ' Returns
    ' ---------
    ' Boolean (存在すればTrue)
    '''
    Dim rngTargetIdColumn As Range
    Dim rngTargetIdCell As Range
    
    '' (1) IDの有無を判定するカラムを選択
    Set rngTargetColumn = loTarget.ListColumns(intIdColumnIdx).DataBodyRange
    
    '' (2) varTargetIdを含むデータをFindで検索
    Set rngTargetIdCell = rngTargetColumn.Find(varTargetId, LookIn:=xlValues, LookAt:=xlWhole)
    
    '' (3) 検索結果をBooleanに変換
    CheckExistenceId = Not rngTargetIdCell Is Nothing
End Function

③ 次にCopyTableToOtherExcelとCheckExistenceIdを組み合わせます。

OverwriteTableToOtherExcel
Function OverwriteTableToOtherExcel(ByVal strSourceSheetName As String, _
                                                            ByVal strSourceTableName As String, ByVal strTargetFilePath As String, _
                                                            ByVal strTargetSheetName As String, ByVal strTargetTableName As String, _
                                                            ByVal intIdColumnIdx As Integer, ByVal strIdColumnName As String, _
                                                            Optional boolCheck As Boolean = True)
    '''
    ' CopyTableToOtherExcelの機能追加ver.
    ' マクロを実行しているExcelファイル(source)のテーブルを、別のExcelファイル(target)のテーブルに追記する
    ' 同じIDのレコードがすでにtargetに存在している場合に、上書きを実行するか否かを確認する
    ' 上書きを実行する場合はtargetのレコードを削除したうえでペーストを実行する
    '
    ' Parameters
    ' -------------
    ' strSourceSheetName : String, コピー対象のテーブルが記入されたシートの名前.
    ' strSourceTableName : String, コピー対象のテーブル名.
    ' strTargetFilePath : String, ペースト対象のファイルパス.
    ' strTargetSheetName : String, ペースト対象のテーブルが記入したシートの名前.
    ' strTargetTableName : String, ペースト対象のテーブル名.
    ' intIdColumnIdx : Integer, 同じIDのレコードが存在しているかどうかを判定する対象となるカラム番号
    ' strIdColumnName : String, 上記のIDが入っているコピー対象のカラム名
    ' boolCheck : Boolean, 上書きのチェックを行うか否か
    '
    ' Returns
    ' ---------
    ' None.
    '''
    Dim strCheckId As String
    
    Dim wsSource As Worksheet
    Dim rngSource As Range
    Dim loSource As ListObject
    Dim rngSourceData As Range
    
    Dim wbTarget As Workbook
    Dim wsTarget As Worksheet
    Dim loTarget As ListObject
    Dim rngTargetData As Range
    Dim rngTargetDelete As Range
    
    '' (1) 出力するデータのIDを取得（ワークシート関数を使用）
    With WorksheetFunction
        strCheckId = .Transpose(.Unique(Worksheets(strSourceSheetName).Range(strSourceTableName & "[" & strIdColumnName & "]")))(1)
    End With
    
    '' (2) ペースト先の情報を取得
    Set wbTarget = Workbooks.Open(strTargetFilePath)
    Set wsTarget = wbTarget.Sheets(strTargetSheetName)
    Set loTarget = wsTarget.ListObjects(strTargetTableName)
    
    '' (3) ペースト先のレコードの有無を確認
    If loTarget.DataBodyRange Is Nothing Then ' 空の場合
        ' アクティブなブックを切り替える
        ThisWorkbook.Activate
        ' コピー & ペースト
        Call CopyTableToOtherExcel(strSourceSheetName, strSourceTableName, strTargetFilePath, strTargetSheetName, strTargetTableName)
        
    Else ' 空でない場合
        '' (4) コピーしたデータのIDがすでにペースト先に登録されているかを確認
        If CheckExistenceId(loTarget, intIdColumnIdx, strCheckId) Then
            '' (5) 上書きの実行確認を行うか否か
            If boolCheck Then ' 確認する場合
                '' (6) 上書きの実行確認
                Dim response As VbMsgBoxResult
                response = MsgBox("上書きを実行しますか?", vbQuestion + vbYesNo, "確認") ' MsgBoxで上書きを実行するかどうかを確認
                
                If response = vbYes Then ' 上書きを実行する場合
                    ' ペースト先においてIDが被っているデータを削除
                    loTarget.Range.AutoFilter Field:=intIdColumnIdx, Criteria1:=strCheckId '指定した値でフィルター
                    Set rngTargetDelete = loTarget.DataBodyRange.SpecialCells(xlCellTypeVisible)  '指定した行の範囲を指定
                    rngTargetDelete.EntireRow.Delete '削除
                    loTarget.AutoFilter.ShowAllData 'フィルターを解除
                    
                    ' アクティブなブックを切り替え
                    ThisWorkbook.Activate
                    
                    ' コピー
                    Call CopyTableToOtherExcel(strSourceSheetName, strSourceTableName, strTargetFilePath, strTargetSheetName, strTargetTableName)
                    
                Else ' 上書きしない場合
                    MsgBox "キャンセル"
                    wbTarget.Close ' ペースト先のファイルを閉じる
                End If
            Else ' 確認しない場合
                ' ペースト先においてIDが被っているデータを削除
                loTarget.Range.AutoFilter Field:=intIdColumnIdx, Criteria1:=strCheckId '指定した値でフィルター
                Set rngTargetDelete = loTarget.DataBodyRange.SpecialCells(xlCellTypeVisible)  '指定した行の範囲を指定
                rngTargetDelete.EntireRow.Delete '削除
                loTarget.AutoFilter.ShowAllData 'フィルターを解除
                
                ' アクティブなブックを切り替え
                ThisWorkbook.Activate
                
                ' コピー
                Call CopyTableToOtherExcel(strSourceSheetName, strSourceTableName, strTargetFilePath, strTargetSheetName, strTargetTableName)
            End If
        Else ' 登録がない場合
            ' アクティブなブックの切り替え
            ThisWorkbook.Activate
            
            ' コピー
            Call CopyTableToOtherExcel(strSourceSheetName, strSourceTableName, strTargetFilePath, strTargetSheetName, strTargetTableName)
        End If
    End If
End Function

関数の準備は以上です。

2. データの準備

今回は以下のような2つのデモデータを準備します。

① コピーしたいデータ(output)

id col1 col2
id3 C 3

② コピー先のデータ(target)

id col1 col2
id1 A 1
id2 B 2

3. 実行

①「CopyTableToOtherExcel」単体で運用する場合
以下のようにシート名、テーブル名、ファイルパスを指定して関数を実行します。

runCopyAndPaste
Sub runCopyAndPaste()
    '' (1) Source, Targetなどの引数を設定
    Dim strSourceSheetName As String: strSourceSheetName = "Sheet1"
    Dim strSourceTableName As String: strSourceTableName = "source"
    Dim strTargetFilePath As String: strTargetFilePath = "ご自身の環境におけるファイルパスを記載してください"
    Dim strTargetSheetName As String: strTargetSheetName = "Sheet1"
    Dim strTargetTableName As String: strTargetTableName = "target"
    
    '' (2) CopyTableToOtherExcelを実行
    Call CopyTableToOtherExcel(strSourceSheetName, strSourceTableName, _
                                                strTargetFilePath, _
                                                strTargetSheetName, strTargetTableName)
End Sub

② IDに基づいて、上書きチェックを行いたい場合
「CopyTableToOtherExcel」の代わりに「OverwriteTableToOtherExcel」を実行します。

runOverwrite
Sub runOverwrite()
    '' (1) Source, Target, IDなどの引数を設定
    Dim strSourceSheetName As String: strSourceSheetName = "Sheet1"
    Dim strSourceTableName As String: strSourceTableName = "source"
    Dim strTargetFilePath As String: strTargetFilePath = "C:\Users\tkvb1\OneDrive\1_Qiita\02_Excel\1_データ出力\target.xlsx"
    Dim strTargetSheetName As String: strTargetSheetName = "Sheet1"
    Dim strTargetTableName As String: strTargetTableName = "target"
    Dim intIdColumnIdx As Integer: intIdColumnIdx = 1
    Dim strIdColumnName As String:: strIdColumnName = "id"
    
    ' (2) OverwriteTableToOtherExcelを実行
    Call OverwriteTableToOtherExcel(strSourceSheetName, _
                                                        strSourceTableName, strTargetFilePath, _
                                                        strTargetSheetName, strTargetTableName, _
                                                        intIdColumnIdx, strIdColumnName)

End Sub

4. さいごに

これ単体ではあまり使い道がないかもしれませんが、
色々と組み合わせるとExcelだけでもある程度データマネジメントが可能です。
最終的にはクラウド等を使うことになりますが、スモールスタートには便利かなと考えています。

今後、Excel-VBA × データマネジメントについて投稿していき、
最後に全体像をまとめさせていただきたいと思います。

2
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
2
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?