２ブックの表を照らし合わせて更新するマクロのテンプレート | エクセルマクロ(VBA)実践蔵(じっせんぐら)

トップ項目一覧

下記の記事で使用した説明用の表を使用して、エクセルファイルを２つ開いて、２つの表のデータを比べて

更新するテストマクロを作成しました。エクセルマクロ中級編として、そして、２つのブックを開く、テンプレートにもなるかと思い、作ってみました。

• 関連記事
• エクセルマクロの基本（初級）その１
• エクセルマクロの基本（初級）その２
• エクセルマクロの基本（初級）その３

ブックを2つ開いて、表を照合し、更新するマクロ(テンプレートになるかな)

マクロ有効ブックと同じ階層に「テストA.xlsx」ファイルと「テストB.xlsx」ファイルがある想定です。

テストAファイルとテストBファイルで表の構成を変えています。テストAファイルはシート名「Sheet1」をテストBファイルはシート名「Sheet2」を参照しています。

マクロ有効ブックで実行を行い、テストBファイルの更新を行い、テストAファイルは参照をします。テストBファイルの名前に登録されている名前と一致する名前をテストAファイルから探し、住所の更新を行います。(テストなので住所欄だけです。郵便番号欄は変えてません。)

 
Sub BookOpenAndReadWriteTest() 
     
    '変数宣言 
    Dim FileNameA As String, FileNameB As String 
    Dim pathA As String, pathB As String 
    Dim WbkA As Workbook, WbkB As Workbook 
    Dim WshtA As Worksheet, WshtB As Worksheet 
    Dim NameTitleARng As Range, NameTitleBRng As Range 
    Dim AddrsTitleARng As Range, AddrsTitleBRng As Range 
     
    Dim 名前列AのRngs As Range, 名前列BのRngs As Range 
    Dim oneARng As Range, oneBRng As Range 
    Dim AddressAStr As String, AddressBStr As String 
         
    FileNameA = "テストA.xlsx" 
    FileNameB = "テストB.xlsx" 
     
    'ThisWorkbook.pathは、マクロ有効ブックの格納フォルダパス 
    'そのpathと開くファイル名を連結させる 
    pathA = ThisWorkbook.path & "/" & FileNameA 
    pathB = ThisWorkbook.path & "/" & FileNameB 
     
    If Dir(pathA) <> "" And Dir(pathB) <> "" Then 
    'ファイルが存在する場合 
        Set WbkA = Workbooks.Open(pathA) 
        Set WbkB = Workbooks.Open(pathB) 
    Else 
    'いずれか又は両方のファイルが存在しない 
        MsgBox "ファイルが開けませんでした。" 
        Exit Sub 
    End If 
     
    'ブック内のシート数分でループ 
    For Each WshtA In WbkA.Worksheets 
        'Sheet1があるか確認 
        If WshtA.Name = "Sheet1" Then 
            Exit For 
        End If 
    Next 
     
    For Each WshtB In WbkB.Worksheets 
        'Sheet2があるか確認 
        If WshtB.Name = "Sheet2" Then 
            Exit For 
        End If 
    Next 
     
    '目当てのシートを見つけた 
    If Not WshtA Is Nothing And Not WshtB Is Nothing Then 
         
        '使われている行の一番上から表題(名前)のセル情報を取得 
        Set NameTitleARng = WshtA.UsedRange.Rows(1).Find("名前", LookAt:=xlWhole) 
        Set NameTitleBRng = WshtB.UsedRange.Rows(1).Find("名前", LookAt:=xlWhole) 
         
        Set AddrsTitleARng = WshtA.UsedRange.Rows(1).Find("住所", LookAt:=xlWhole) 
        Set AddrsTitleBRng = WshtB.UsedRange.Rows(1).Find("住所", LookAt:=xlWhole) 
         
        '表題から名前と住所をそれぞれ見つけたか確認 
        If Not NameTitleARng Is Nothing And Not NameTitleBRng Is Nothing And _ 
           Not AddrsTitleARng Is Nothing And Not AddrsTitleBRng Is Nothing Then 
             
            'シートAの名前検索範囲を求める(Find用) 
            For Each 名前列AのRngs In WshtA.UsedRange.Columns 
                If 名前列AのRngs.Column = NameTitleARng.Column Then 
                    'Aシートの名前の列数と一致する列情報を取得 
                    Exit For 
                End If 
            Next 
             
            'シートBの名前欄の範囲を求める(For Each用) 
            For Each 名前列BのRngs In WshtB.UsedRange.Columns 
                If 名前列BのRngs.Column = NameTitleBRng.Column Then 
                    'Bシートの名前の列数と一致する列情報を取得 
                    Exit For 
                End If 
            Next 
             
            'シートBの名前数分ループ 
            For Each oneBRng In WshtB.Range(名前列BのRngs.Address) 
                 
                If Not oneBRng.Row = NameTitleBRng.Row Then 
                '表題の行でなければ、 
                     
                    'Find関数で探す（Bシートの名前をAシートで探す） 
                    Set oneARng = 名前列AのRngs.Find(oneBRng.Value, LookAt:=xlWhole) 
                     
                    '見つかったか確認する 
                    If Not oneARng Is Nothing Then 
                         
                        '住所文字列をそれぞれ取得 
                        AddressAStr = WshtA.Cells(oneARng.Row, AddrsTitleARng.Column).Value 
                        AddressBStr = WshtB.Cells(oneBRng.Row, AddrsTitleBRng.Column).Value 
                         
                        '住所の比較 
                        If StrComp(AddressAStr, AddressBStr, vbTextCompare) = 0 Then 
                            '一致する 
                        Else 
                            '一致しない 
                            'Aの情報をBへ設定する 
                            WshtB.Cells(oneBRng.Row, AddrsTitleBRng.Column).Value = AddressAStr 
                            Debug.Print "テストBファイルのSheet2の更新位置：" & WshtB.Cells(oneBRng.Row, AddrsTitleBRng.Column).Address 
                         
                        End If '住所の比較 
                     
                    End If 'Find結果確認 
                 
                End If '表題以外の行 
                         
            Next '次の名前を取得 
      
        Else ' 表題から名前と住所が見つけられない 
         
            MsgBox "名前又は住所の欄が見つかりませんでした。" 
             
        End If 
         
    Else '目当てのシートが見つからない 
         
        MsgBox "シートが見つかりませんでした。" 
     
    End If 
     
    '開いたブックを保存して閉じる 
    WbkA.Close 
    WbkB.Close SaveChanges:=True 
         
    'メモリ解放 
    Set WbkA = Nothing 
    Set WbkB = Nothing 
    Set WshtA = Nothing 
    Set WshtB = Nothing 
    Set NameTitleARng = Nothing 
    Set NameTitleBRng = Nothing 
    Set AddrsTitleARng = Nothing 
    Set AddrsTitleBRng = Nothing 
    Set 名前列AのRngs = Nothing 
    Set 名前列BのRngs = Nothing 
    Set oneARng = Nothing 
    Set oneBRng = Nothing 
     
End Sub

ブックが２つになると変数が多くなりました。

作るだけ作ったので載せてみました。

UsedRangeを使用して使用されているセル範囲のみを参照しています。

上のコードを動作させるには「使用されているセルの一行目が表題である」という条件と、各シートに表が一つという条件がつきます。

表題の位置が変わるなら「Rows(1)」の部分を変更する必要があります。

また、複数の表や情報が記述されているシートなら、表の範囲の判断が別で必要です。

初級編の延長で書いていたので、UsedRangeとFor Eachを使用しています。

ブックを2つ開いて、表を照合し、更新するマクロの解説

表題から名前の欄と住所の欄をそれぞれのブックのシートから列の特定を行います。

列が特定できたら、名前の列の使用されているセル範囲を求めています。

Bファイルの名前数分ループし、Aファイルの名前欄で検索(Find関数)を使用しています。

一致する位置の住所の比較を行い、更新が必要なら、AファイルからBファイルへ情報を移しています。