【Excel VBA】他Excelファイルのセル範囲の値を一括取得するツール(コピペで即利用)

 

 

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

 

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

 

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

 

『他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)を起動させます。

 

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

(参考サイト:記事「Excel VBAを始める前に、最初にやっておくべき初期設定内容はこれ」の『開発』タブを表示させる

 

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

 

※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 yPoint As Long
                Dim xPoint As Long
                
                If ProcessCnt <> 0 Then
                    yPoint = BaseBook.Sheets(TgtSheetNm).Range(PStartCell).Row
                    xPoint = BaseBook.Sheets(TgtSheetNm).Range(PStartCell).SpecialCells(xlCellTypeLastCell).Column + 1
                    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」形式(マクロが動作するファイル形式)で保存します。

 

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

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

 

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

 

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

 

正常に動作しない場合は、コメントいただければ幸いです。

 

サンプルのダウンロードはこちら

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

上記よりダウンロードして、VBAコードを組み込んでマクロを使用してください。

 

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

 

コメントを残す

CAPTCHA