【Excel VBA】他Excelファイルのセル範囲の値を一括で取得して、貼り付けるツール(コピペですぐ使える)

 

複数あるExcelファイルまたは複数シートのある部分のセルを一括で取得して値を貼り付けたいと思ったことはないでしょうか。

 

例えば、定例業務として毎月のデータが入ったExcelファイルをあるフォルダにまとめて保存されており、その中のある一部分(特定のセル範囲)のデータをとるために、複数あるファイルを一つずつ開いて特定の部分をコピペ&コピペ&コピペ…という非常に手間がかかる作業をしていないだろうか。

 

それらのファイルを開いてコピペ、開いてコピペ…という手間がかかる作業をボタン一つで完了させるツール『他Excelファイルのセル範囲の値を一括取得するツール』をExcelマクロで作成しましたので、是非ご活用頂けたらと思います。

 

また、似たツールとして、別ファイルの指定した範囲を、任意のファイルのセルに貼り付けるツールも作成しましたので、よろしければご参照ください。

 

<ツール更新履歴>

(2022年9月3日:更新) 貼り付けルールを「左列から順に貼り付け」で、かつ「終了セル」で指定されたセルが “結合されたセル” であった場合に正常に動作しない不具合を修正しました。

 

『他Excelファイルのセル範囲の値を一括取得するツール』の概要

取得したセル範囲や貼り付けるルール等を指定する設定画面(設定シート)を用意して、設定画面内で以下を指定します。

  • コピーするセル範囲(開始セル、終了セル)
  • 対象にするシート名(※なければ全てのシート)
  • 貼り付けるセル位置
  • 貼り付け形式(全て、値、数式を貼り付け。から選択)
  • 貼り付けルール(シート別に貼り付け、左列から順に貼り付け。から選択)

 

後は、対象のExcelファイルを指定して実行するか、当ツールがある同階層のExcelファイル全てに対して実行するかを押すボタンを変えることで選択できます。

 

下に説明動画を載せますので、ご確認ください。

動画を見ると分かりやすいと思います。

 

<説明動画>

現在準備中…

 

当ツールの使用方法

基本的な機能、操作方法の説明

1.実行するマクロが入ったExcelファイル(当ツールのマクロ付き)を開きます。

※当ツールのVBAコードを含んでいて、「設定」シート(設定情報を書き込めるシート)がファイル内に存在している状態のファイルです。

 

2.「設定」シート内で当ツールを実行するために、以下の設定値を記載します。

  • コピーするセル範囲(開始セル、終了セル)
  • → 列アルファベット、行番号の順で入力してください。例:A1、D20 など
  • 対象にするシート名
  • → 値がない場合は、対象のExcelファイル内の全てのシートを対象にセル範囲の値を取得します。
  • 貼り付けるセル位置
  • → 列アルファベット、行番号の順で入力してください。
    なお、<貼り付けルール>で「左列から順に貼り付け」が選択されている場合は、このセル位置から始まり、貼り付け後の一つ右にあるセルに順に貼り付けられていきます。
  • 貼り付け形式(全て、値、数式を貼り付け。から選択)
  • → どれか一つに「〇」を選択してください。
  • 貼り付けルール(シート別に貼り付け、左列から順に貼り付け。から選択)
  • → どれか一つに「〇」を選択してください。
    「左列から順に貼り付け」を選択した場合は、一つのシートで指定した貼り付ける開始セルから左に順に貼り付けられます。
    ※シート名はファイル名から拡張子を無くした名称になります。

 

3.「Excelファイルを指定して値を取込」か「同階層の全Excelファイルの値を取込」のどちらかのボタンを押します。

 

「Excelファイルを指定して値を取込」を押した場合は、ファイルを指定するダイアログが表示されますので、対象のExcelファイルを選択してツールを実行してください。

 

「同階層の全Excelファイルの値を取込」を押した場合は、当ツールが配置されている階層と同じ階層にある全Excelファイルを対象として当ツールが実行されます。

 

また、同階層のファイルを対象にして実行した場合のシート名は変更できますので、必要に応じてカスタマイズして頂ければと思います。

 

留意事項

セルの指定ルール

セルの指定する箇所は列アルファベット、行番号の順で記載する必要があり、列番号、行番号の場合は正常に動作しない可能性があります。

取り込んだ際に同名のシートが存在した場合の処理

既にあるシートを取り込んだ場合は、シート名+連番のような形式のシート名になります。

 

使用する際の事前準備

このページの下部にある「Excelファイルのツール」からExcelファイルを取得し、「準備の手順」内にあるVBAコードを取得したExcelファイルに記載して保存すれば、すぐに当ツールを使用できます。

 

以下にその手順を説明していきます。

 

準備の手順

1.当ツールのダウンロードはこちら」からサンプル(Excelファイル)をダウンロードします。

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、設定画面(設定シート)が入っているマクロ無しExcelファイルを公開しています

※このサイトからExcelファイルをダウンロードしなくても、設定シートが下記の画像とセル位置が同一のシートを作れば当ツールを動かすことができます

 

2.ダウンロードしたExcelファイルの上部にあるリボンの「開発」タブから「visual basic」を選択して、VBE(visual basic for application)を起動させます。

 

リボンに「開発」タブが表示されていない場合は、以下を参照ください

 

3.「プロジェクト」に「標準モジュール」を追加して、追加された「Module1」にVBAコードを記載します。

 

VBAのソースコードはこちら

以下のVBAコードをコピーして、「Module1」内のエディターに貼り付けます。

※VBAコードの右上のアイコンをクリックするとソースコードをコピーできます

Option Explicit

'-----(設定値)------------------------
Private Const CStartCellPoint = "B5"        '1.設定シート内のコピーする開始セル位置
Private Const CEndCellPoint = "C5"          '2.設定シート内のコピーする終了セル位置
Private Const CSheetNmPoint = "F4"          '3.設定シート内のコピーするシート名
Private Const PCellPoint = "C9"             '4.設定シート内の貼り付けする開始セル位置
Private Const POpt1PointX = 3               '5.設定シート内の貼り付けオプションの開始位置(X軸)
Private Const POpt1PointY = 13              '6.設定シート内の貼り付けオプションの開始位置(Y軸)
Private Const POpt2PointX = 3               '7.設定シート内の貼り付け場所の開始位置(X軸)
Private Const POpt2PointY = 18              '8.設定シート内の貼り付け場所の開始位置(Y軸)
Private Const MltFileSheetNm = "統合"       '9.「同階層の全ファイルを対象」かつ「左列から順に貼り付け」で実行した際のシート名

'-----(メッセージ)--------------------
Private Const Msg1 = "指定したシートが存在しません。"
Private Const Msg2 = "指定したExcelファイル内のセル範囲の値の取込が完了しました。"
Private Const Msg3 = "同階層にある全Excelファイル内のセル範囲の値の取込が完了しました。"
Private Const WMsg1 = "貼り付け形式を複数選択しているか、または一つも選択していません。" & vbCrLf & "一つだけ選択してください。"
Private Const WMsg2 = "貼り付けルールを複数選択しているか、または一つも選択していません。" & vbCrLf & "一つだけ選択してください。"
Private Const EMsg1 = "予期せぬエラーが発生しました。"
'---------------------------------------

Dim CStartCell As String
Dim CEndCell As String
Dim CSheetNm As String
Dim PStartCell As String
Dim PasteOpt1 As String
Dim PasteOpt2 As String
Dim ProcessCnt As Long
Dim TgtSheetNm As String
Dim BaseBook As Workbook
Dim SettingSheet As Worksheet

'===================================
'Excelファイルを指定して取込した際の処理
'===================================
Sub Click_ファイル指定して取込()

    On Error GoTo err
    ProcessCnt = 0
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim filePath As String
    Dim fileName As String

    Set BaseBook = ActiveWorkbook
    Set SettingSheet = ActiveSheet

    '設定情報を取得する
    Call GetSetting

    'Excelファイルを指定するダイアログの表示
    filePath = Application.GetOpenFilename(Filefilter:="Microsoft Excelブック,*.xls?", Title:="取り込むExcelファイルを指定してください。")

    If filePath <> "False" Then
        
        fileName = Dir(filePath)
        Workbooks.Open (filePath), UpdateLinks:=1
        
        '他Excelファイルの値を取得して、実行したExcelファイルに貼り付ける
        Call GetPasteSheetInfo(fileName, 1)
        
    'キャンセルが選択された場合はダイアログを閉じる
    Else
        End
    End If
    
    Worksheets(SettingSheet.Name).Select
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox Msg2 & vbCrLf & "取込件数:" & ProcessCnt & "件"
    ProcessCnt = 0
    Exit Sub
    
err:
    MsgBox EMsg1, vbOKOnly + vbCritical
    
End Sub

'===================================
'同階層の全Excelファイルを取込した際の処理
'===================================
Sub Click_全ファイルを取込()
    
    On Error GoTo err
    ProcessCnt = 0
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim fileName As String

    Set BaseBook = ActiveWorkbook
    Set SettingSheet = ActiveSheet
    
    '設定情報を取得する
    Call GetSetting
    
    '同階層にあるExcelファイルを全て取得する
    fileName = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
    
    Do While fileName <> ""
        Workbooks.Open ThisWorkbook.Path & "\" & fileName
        
        '他Excelファイルの値を取得して、実行したExcelファイルに貼り付ける
        Call GetPasteSheetInfo(fileName, 2)
        
        fileName = Dir
    Loop
    
    Worksheets(SettingSheet.Name).Select
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox Msg3 & vbCrLf & "取込件数:" & ProcessCnt & "件"
    ProcessCnt = 0
    Exit Sub
    
err:
    MsgBox EMsg1, vbOKOnly + vbCritical
    
End Sub

'-------------------------
'設定情報を取得する
'-------------------------
Sub GetSetting()

    Dim i
    Dim opt1SelCnt As Long: opt1SelCnt = 0
    Dim opt2SelCnt As Long: opt2SelCnt = 0
    
    CStartCell = ActiveSheet.Range(CStartCellPoint).Value
    CEndCell = ActiveSheet.Range(CEndCellPoint).Value
    PStartCell = ActiveSheet.Range(PCellPoint).Value
    CSheetNm = ActiveSheet.Range(CSheetNmPoint).Value
    
    For i = POpt1PointY To POpt1PointY + 2
        If Trim(ActiveSheet.Cells(i, POpt1PointX).Value) <> "" Then
            PasteOpt1 = i - (POpt1PointY - 1)
            opt1SelCnt = opt1SelCnt + 1
        End If
    Next
    
    For i = POpt2PointY To POpt2PointY + 1
        If Trim(ActiveSheet.Cells(i, POpt2PointX).Value) <> "" Then
            PasteOpt2 = i - (POpt2PointY - 1)
            opt2SelCnt = opt2SelCnt + 1
        End If
    Next
    
    '貼り付けオプションを複数選択している場合は、文字色を変更して注意メッセージを表示させる
    If opt1SelCnt > 1 Or opt1SelCnt = 0 Then
        SettingSheet.Cells(POpt1PointY, POpt1PointX).Font.ColorIndex = 3
        SettingSheet.Cells(POpt1PointY + 1, POpt1PointX).Font.ColorIndex = 3
        SettingSheet.Cells(POpt1PointY + 2, POpt1PointX).Font.ColorIndex = 3
        MsgBox WMsg1, vbExclamation
        End
    Else
        SettingSheet.Cells(POpt1PointY, POpt1PointX).Font.ColorIndex = 1
        SettingSheet.Cells(POpt1PointY + 1, POpt1PointX).Font.ColorIndex = 1
        SettingSheet.Cells(POpt1PointY + 2, POpt1PointX).Font.ColorIndex = 1
    End If
    
    If opt2SelCnt > 1 Or opt2SelCnt = 0 Then
        SettingSheet.Cells(POpt2PointY, POpt2PointX).Font.ColorIndex = 3
        SettingSheet.Cells(POpt2PointY + 1, POpt2PointX).Font.ColorIndex = 3
        MsgBox WMsg2, vbExclamation
        End
    Else
        SettingSheet.Cells(POpt2PointY, POpt2PointX).Font.ColorIndex = 1
        SettingSheet.Cells(POpt2PointY + 1, POpt2PointX).Font.ColorIndex = 1
    End If
End Sub

'-------------------------
'他Excelファイルの値を取得して、実行したExcelファイルに貼り付ける
' 引数:ファイル名、処理種類(1:ファイルを指定して実行、2:全Excelファイルを対象に実行)
'-------------------------
Sub GetPasteSheetInfo(fileName As String, doType As Long)

    Dim selBook As Workbook
    Set selBook = ActiveWorkbook
    Dim tmpSheet As Worksheet
    
    Dim tmpWs As Worksheet
    Dim existFlg As Boolean: existFlg = False
    
    '「対象シート名」が空白じゃない場合、対象ファイル内に当該シートが存在するか確認する
    If CSheetNm <> "" Then
        
        For Each tmpWs In selBook.Worksheets
            If tmpWs.Name = CSheetNm Then existFlg = True
        Next tmpWs
        If existFlg = False Then
            MsgBox "「" & fileName & "」には" & Msg1, vbInformation
            selBook.Close SaveChanges:=False
            Exit Sub
        End If
    End If
    
    '貼り付けルールが「左から順に貼り付ける」の場合
    If PasteOpt2 = 2 Then
    
        If doType = 1 Then
        
            '拡張子無のファイル名を取得する
            TgtSheetNm = Left(Left(fileName, InStrRev(fileName, ".") - 1), 31)
            
            existFlg = False
            
            '既に存在しているシート名の場合は、シート名の後に連番を付与する
            For Each tmpWs In BaseBook.Worksheets
                If tmpWs.Name = TgtSheetNm Then existFlg = True
            Next tmpWs
            
            If existFlg = True Then
                BaseBook.Worksheets(TgtSheetNm).Copy After:=BaseBook.Worksheets(TgtSheetNm)
                TgtSheetNm = ActiveSheet.Name
                
                Application.DisplayAlerts = False
                BaseBook.Worksheets(TgtSheetNm).Delete
                Application.DisplayAlerts = True
            End If
        
            'ツールを実行したExcelファイルに新規シートを作成する
            BaseBook.Sheets.Add After:=BaseBook.Sheets(BaseBook.Sheets.Count)
            BaseBook.Sheets(BaseBook.Sheets.Count).Name = TgtSheetNm
            
        ElseIf doType = 2 And ProcessCnt = 0 Then
        
            '新規シート名称を予め設定した値にして、新規シートを作成する
            TgtSheetNm = MltFileSheetNm
            BaseBook.Sheets.Add After:=BaseBook.Sheets(BaseBook.Sheets.Count)
            BaseBook.Sheets(BaseBook.Sheets.Count).Name = TgtSheetNm
            
        Else
        End If
        
    End If
    
    '対象ファイルの全シートを1つずつループして処理する
    For Each tmpSheet In selBook.Worksheets
        
        If CSheetNm = "" Or tmpSheet.Name = CSheetNm Then
        
            '貼り付けルールが「シート毎に貼り付ける」の場合
            If PasteOpt2 = 1 Then
            
                Dim tmpSheetNm As String
                
                '既に存在しているシート名の場合は、シート名の後に連番を付与する
                tmpSheet.Copy After:=BaseBook.Worksheets(SettingSheet.Name)
                tmpSheetNm = ActiveSheet.Name
                
                Application.DisplayAlerts = False
                BaseBook.Worksheets(tmpSheetNm).Delete
                Application.DisplayAlerts = True
                
                BaseBook.Sheets.Add After:=BaseBook.Sheets(BaseBook.Sheets.Count)
                BaseBook.Sheets(BaseBook.Sheets.Count).Name = tmpSheetNm

                tmpSheet.Range(CStartCell & ":" & CEndCell).Copy
    
                Select Case PasteOpt1
                    Case 1
                        '全てを貼り付け
                        BaseBook.Sheets(tmpSheetNm).Range(PStartCell).PasteSpecial Paste:=xlPasteAll
                    Case 2
                        '値を貼り付け
                        BaseBook.Sheets(tmpSheetNm).Range(PStartCell).PasteSpecial Paste:=xlPasteValues
                    Case 3
                        '数式を貼り付け
                        BaseBook.Sheets(tmpSheetNm).Range(PStartCell).PasteSpecial Paste:=xlPasteFormulas
                End Select
                
            '貼り付けルールが「左から順に貼り付ける」の場合
            Else
                
                Dim pSCell As String        '貼り付けを開始するセル
                Dim yEndPoint As Long       '貼り付けが終了する行番号
                Dim xEndPoint As Long       '貼り付けが終了する列番号
                Dim yPoint As Long          '次の貼り付けを開始する行番号
                Dim xPoint As Long          '次の貼り付けを開始する列番号
                
                If ProcessCnt <> 0 Then
                    
                    xEndPoint = BaseBook.Sheets(TgtSheetNm).Range(PStartCell).SpecialCells(xlCellTypeLastCell).Column
                    yEndPoint = BaseBook.Sheets(TgtSheetNm).Range(PStartCell).SpecialCells(xlCellTypeLastCell).Row
                    
                    '最後の列が結合セルの場合と異なる場合で列番号の取得方法を変更する
                    If BaseBook.Sheets(TgtSheetNm).Cells(yEndPoint, xEndPoint).MergeCells Then
                        xPoint = xEndPoint + BaseBook.Sheets(TgtSheetNm).Cells(yEndPoint, xEndPoint).MergeArea.Columns.Count
                    Else
                        xPoint = BaseBook.Sheets(TgtSheetNm).Range(PStartCell).SpecialCells(xlCellTypeLastCell).Column + 1
                    End If
                    
                    yPoint = BaseBook.Sheets(TgtSheetNm).Range(PStartCell).Row
                    pSCell = Cells(yPoint, xPoint).Address
                Else
                    pSCell = PStartCell
                End If
                
                tmpSheet.Range(CStartCell & ":" & CEndCell).Copy
                
                Select Case PasteOpt1
                    Case 1
                        '全てを貼り付け
                        BaseBook.Sheets(TgtSheetNm).Range(pSCell).PasteSpecial Paste:=xlPasteAll
                    Case 2
                        '値を貼り付け
                        BaseBook.Sheets(TgtSheetNm).Range(pSCell).PasteSpecial Paste:=xlPasteValues
                    Case 3
                        '数式を貼り付け
                        BaseBook.Sheets(TgtSheetNm).Range(pSCell).PasteSpecial Paste:=xlPasteFormulas
                End Select
                
            End If
            ProcessCnt = ProcessCnt + 1
        End If
    Next
    
    Workbooks(fileName).Close SaveChanges:=False

End Sub

 

4.作成したExcelファイルを「.xlsm」形式(マクロが動作するファイル形式)で保存します。

 

5.「Excelファイルを指定して値を取込」と記載された図形にメイン処理「Click_ファイル指定して取込」のマクロを設定します。

6.「同階層の全Excelファイルの値を取込」と記載された図形にメイン処理「Click_全ファイルを取込」のマクロを設定します。

 

これで事前準備は完了です

あとは「ツールの使用方法」で記載された方法で当ツールを実行できます。

 

また、このようなExcelVBAを用いた業務効率化を行うときに、以下の書籍が初心者向けでとても参考になると思いますので、良かったらご参照ください。

 

なお、当マクロの開発環境として、OSは “Windows10” 、Excelのバージョンは “Microsoft Office 365″ で行っており、当環境では動作確認ができていますが、他のすべての環境で正常に動作するかは確認できていません。

 

正常に動作しない場合は、コメントいただければ幸いです。
また、このような業務効率化できるツールを以下に一覧でまとめてありますので、ご興味のある方はご覧ください。

 

当ツールのダウンロードはこちら

下記よりExcelファイルをダウンロードして、記事の途中にありました VBAのソースコードをツール内に組み込んで使用してください。

 

【Excel VBA】他Excelファイルのセル範囲の値を一括取得するツール

※インターネットにあるマクロファイルをダウンロードすることはセキュリティ上リスクがあるので、マクロ無しExcelファイルを公開しています

 

他に要望等ありましたら、可能な限り改修等を対応しますのでコメント頂ければと思います

 

<このツールが『結構使える!』と思ったら、下のグッドボタンを押していただけたら幸いです>

【Excel VBA】他Excelファイルのセル範囲の値を一括で取得して、貼り付けるツール(コピペですぐ使える)” に対して9件のコメントがあります。

  1. ヨシダ より:

    RH様

    はじめまして、ヨシダと申します。
    これからVBAを学んでいこうと思い、やりたい事を検索した結果このサイトにたどり着きました。

    当方、jsやgasは少し分かる程度でVBAをさわるのは初めてになります。

    本ツール大変すばらしいものと思い、ダウンロードし、モジュール設定をした所、同階層の全ての全Excelファイルの値を取込は機能するものの、Excelファイルを指定して値を取込のボタンを押した所「予期せぬエラーが発生しました」と表示され起動できない状態になりました。Excelのバージョンは2019になります。

    もし原因にお心あたりありましたらご教授お願い出来ないでしょうか?宜しくお願い致します。

  2. 匿名 より:

    RH様

    度々申し訳ありません。

    どうやら読み込めるファイルもある様です。読み込めないファイルとの差を確認し原因を確認したいと思います。

    1. RH より:

      管理人のRHです。
      ヨシダさん、ツールのご使用とコメントありがとうございます。

      調査してみると不具合が見つかりました。
      貼り付けルールを「左列から順に貼り付け」で、かつ「終了セル」で指定されたセルが結合セルであった場合にエラーが発生してうまく動作しませんでした。
      近日中にバグを修正して、改めて公開いたします。

      ご不便おかけしますが、少々お待ちください。

      1. RH より:

        管理人のRHです。
        ヨシダさん、大変遅くなりました。

        2022年9月3日の更新分にて、「予期せぬエラーが発生しました」と表示されて動作しない場合(読み込めるファイルと読み込めないファイルがあり)の不具合がおそらく解消されたと思います。※ソースコードを修正しました。

        一度使用していただき、再度不具合が発生するようでしたら再度コメント願います。

        ====================
        別件として、ご要望でありました既存のシートに上書きすることができるようにする仕様は、もう少々お待ちください。
        大きな修正になりそうなので別のツールとして公開したいと思います。完成しましたら再度お知らせいたします。

  3. ヨシダ より:

    RH様

    ちなみになんですが、貼り付け先を既存のシートに上書きすることは可能でしょうか?

    当方やりたいことは、例えば月間のシフトから日毎のシフトを作成したい。日毎のシフトのシートには関数などで月間のシフトからデータを読み込める

    月間のシフトの書式は同じなので、来月の月間シフトを今月の月間シフトに上書きすれば、来月分の日毎のシフトが自動で作成される。

    お忙しい中とは存じますが何卒よろしくお願いします。

    1. RH より:

      管理人のRHです。
      ヨシダさん、改めてツールのご使用とコメントありがとうございます。
      ※重複したコメントは削除させていただきましたので、ご了承ください。

      下記に関しては、既存のシートに上書きすることは可能だと思います。
      >貼り付け先を既存のシートに上書きすることは可能でしょうか?

      おっしゃっていただいた内容はある程度は理解できたつもりですので、一度構成を検討してみたいと思います。改めてこちらでコメントいたします。

  4. ヨシダ より:

    返信ありがとうございます。更新チェックさせてもらいましす。よろしくお願いいたします。

    1. RH より:

      管理人のRHです。
      ヨシダさん、大変お待たせいたしました。

      貼り付け先を既存のシートに上書きすることは可能な仕様のツールを作成しましたので、一度ご使用いただきイメージと異なる場合は改めてコメント頂けますと幸いです。

      『セル範囲の値を取得して、指定したExcelファイルに貼り付けるツール』(https://resthill.blog/excel-vba-tool19/)

  5. ヨシダ より:

    RH様

    作成ありがとうございます!!

    夜にでも使用させていただきます!

コメントを残す

CAPTCHA