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

特定のファイルのある範囲のセルの値を一括で取得して、他のExcelファイルに横流しで値を貼り付けたいと思ったことはないでしょうか。

 

例えば、定型のフォーマットが入っているExcelファイルに対して、毎月更新されるデータを毎回手動でコピペ&コピペ&コピペ…というとても時間がかかる作業を行っていないだろうか。

 

毎回更新されるデータが入った①Excelファイルを開いて、②セル範囲を選択して、③コピーして、④貼り付けるExcelを開いて、⑤セルを指定して貼り付ける。この5工程を毎回毎回手動で行っているといる場合、それらの操作を自動化できたらどれだけ時間が短縮されるか、業務を効率化できることか。

 

という観点から、指定した範囲を指定したExcelファイルに貼り付けるツール『指定したセル範囲の値を取得して、指定したExcelファイルに貼り付けるツール』をExcelマクロで作成しましたので、是非ご活用頂けたらと思います。

 

<ツールの更新履歴>

(2022年9月25日:更新) 

・ツール全体のUIを変更

 

『指定したセル範囲の値を取得して、指定したExcelファイルに貼り付けるツール』の概要

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

  • コピー元ファイルと貼り付け先のファイル名(ファイルパスを含む)
  • コピー元の設定情報
  • 貼り付け先の設定情報

 

後は、「対象セル範囲の貼り付け実行」ボタンを押すことでコピー元ファイルのセル範囲のデータをコピーして、貼り付け先ファイルのセル位置に貼り付けを行います。

 

当ツールの使用方法

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

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

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

 

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

  • コピー元ファイル名(ダブルクリックしてダイアログから指定してください)
  • 貼り付け先ファイル名(ダブルクリックしてダイアログから指定してください)
  • データを取得するセル範囲の開始セル位置
  • データを取得するセル範囲の終了セル位置
  • データを取得する際に対象とするシート名(※値がなければ全てのシートを対象にします)
  • コピーしたデータを貼り付けるセル位置
  • 貼り付け形式(”全て”、”数式”、”値を貼り付け” から一つだけ選択)
  • 貼り付けルール(”シート別に貼り付け”、”左列から順に貼り付け” から一つだけ選択)
  • 貼り付け先のシート名 ※コピー元ファイルのシート名と同じシート名が貼り付け先ファイルにあった場合は、上書きで貼り付けされます

     

    3.「対象セル範囲の貼り付け実行」のボタンを押します。

     

    コピー元ファイルのデータが貼り付け先ファイルのセルに貼り付けられます。

     

    左列から順に貼り付ける場合

    「貼り付けルール」で『左列から順に貼り付け』を選択した際は以下の挙動になります。

     

    シート別に貼り付ける場合

    「貼り付けルール」で『シート別に貼り付け』を選択した際は以下の挙動になります。

     

    留意事項

    セルの指定ルール

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

    コピー元の対象シートを指定した際にシートが存在しない場合

    指定したシートが存在しない旨のメッセージが表示されます。

     

    使用する際の事前準備

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

     

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

     

    準備の手順

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

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

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

     

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

     

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

     

    3.「ThisWorkbook」内にVBAコードを記載します。

     

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

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

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

    Option Explicit
    
    '-----(設定値)------------------------
    Private Const COPY_START_CELL_POINT = "D17"         '1.設定シート内のコピーする開始セル位置
    Private Const COPY_END_CELL_POINT = "E17"           '2.設定シート内のコピーする終了セル位置
    Private Const COPY_SHEET_NAME_POINT = "D21"         '3.設定シート内のコピーするシート名のセル位置
    Private Const PASTE_CELL_POINT = "J17"              '4.設定シート内の貼り付けする開始セル位置
    Private Const PASTE_OPT1_POINT = "N25"              '5.設定シート内の貼り付けする開始セル位置
    Private Const PASTE_OPT2_POINT = "O25"              '6.設定シート内の貼り付けする開始セル位置
    Private Const MULTI_FILE_SHEET_NAME = "統合"        '7.「同階層の全ファイルを対象」かつ「左列から順に貼り付け」で実行した際のシート名
    Private Const COPY_BOOK_NAME_POINT = "E7"           '8.コピー元Excelファイルを指定するセル位置
    Private Const PASTE_BOOK_NAME_POINT = "E10"         '9.貼り付け先Excelファイルを指定するセル位置
    Private Const PASTE_SHEET_NAME_POINT = "J21"        '10.貼り付け先シート名のセル位置(「左列から順に貼り付け」時のみ指定可能"
    
    '-----(メッセージ)--------------------
    Private Const Msg1 = "指定したシートが存在しません。"
    Private Const Msg2 = "指定したExcelファイル内のセル範囲の値の取込が完了しました。"
    Private Const Msg3 = "同階層にある全Excelファイル内のセル範囲の値の取込が完了しました。"
    Private Const Msg4 = "取り込むExcelファイルを指定してください。"
    Private Const Msg5 = "貼り付け先Excelファイルを指定してください。"
    Private Const WMsg1 = "貼り付け形式を複数選択しているか、または一つも選択していません。" & vbCrLf & "一つだけ選択してください。"
    Private Const WMsg2 = "貼り付けルールを複数選択しているか、または一つも選択していません。" & vbCrLf & "一つだけ選択してください。"
    Private Const WMsg3 = "指定したExcelファイルが見つかりませんでした。"
    Private Const EMsg1 = "予期せぬエラーが発生しました。"
    '---------------------------------------
    
    Dim BaseBook As Workbook        'ツール本体のExcelブック
    Dim SettingSheet As Worksheet   '設定シート
    
    Dim CopyBook As Workbook        'コピー元のExcelブック
    Dim CStartCell As String        'コピー開始のセル位置
    Dim CEndCell As String          'コピー終了のセル位置
    Dim CBookPathNm As String       'コピー元のExcelブック名
    Dim CSheetNm As String          'コピー対象シート名
    
    Dim PasteBook As Workbook       '貼り付け先のExcelブック
    Dim PStartCell As String        '貼り付けるセル位置
    Dim PasteOpt1 As String         '選択された貼り付け形式
    Dim PasteOpt2 As String         '選択された貼り付けルール
    Dim PBookPathNm As String       '貼り付けるExcelブック名
    Dim PSheetNm As String          '貼り付けるシート名
    Dim ProcessCnt As Long          '処理数
    Dim TgtSheetNm As String        '対象のシート名
    
    '===================================
    'Excelファイルを指定して取込した際の処理
    '===================================
    Sub Click_対象セルの貼り付け実行()
    
        On Error GoTo err
        ProcessCnt = 0
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        Set BaseBook = ThisWorkbook
        Set SettingSheet = ActiveSheet
    
        '設定情報を取得する
        Call GetSetting
    
        'コピー元情報のチェック
        Call CheckCopyInfo
        
        '貼り付け先情報のチェック
        Call CheckPasteInfo
        
        '他Excelファイルの値を取得して、実行したExcelファイルに貼り付ける
        Call CopyAndPasteInfo
        
        BaseBook.Activate
        BaseBook.Worksheets(SettingSheet.Name).Select
        
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        
        MsgBox Msg2 & vbCrLf & "コピーしたシート件数:" & ProcessCnt & "件"
    
        Exit Sub
        
    err:
        MsgBox EMsg1, vbOKOnly + vbCritical
        
    End Sub
    
    '-------------------------
    '設定情報を取得する
    '-------------------------
    Sub GetSetting()
    
        CStartCell = ActiveSheet.Range(COPY_START_CELL_POINT).Value     'コピー開始のセル位置
        CEndCell = ActiveSheet.Range(COPY_END_CELL_POINT).Value         'コピー終了のセル位置
        CBookPathNm = ActiveSheet.Range(COPY_BOOK_NAME_POINT).Value     'コピー元のExcelブック
        CSheetNm = ActiveSheet.Range(COPY_SHEET_NAME_POINT).Value       'コピー対象シート名
        PStartCell = ActiveSheet.Range(PASTE_CELL_POINT).Value          '貼り付け開始のセル位置
        PBookPathNm = ActiveSheet.Range(PASTE_BOOK_NAME_POINT).Value    '貼り付け先ファイル名
        PSheetNm = ActiveSheet.Range(PASTE_SHEET_NAME_POINT).Value      '貼り付け先シート(左列から順に貼り付けのみ有効)
        
        Dim selectItem As Variant
        Dim i As Long
        Dim opt1SelCnt As Long: opt1SelCnt = 0
        Dim opt2SelCnt As Long: opt2SelCnt = 0
        
        With ActiveWorkbook.SlicerCaches("スライサー_貼り付け形式")
            For Each selectItem In .SlicerItems
                If selectItem.Selected = True Then
                    opt1SelCnt = opt1SelCnt + 1
                    PasteOpt1 = selectItem.Value
                End If
            Next
        End With
        
        If opt1SelCnt <> 1 Then
            MsgBox WMsg1, vbExclamation
            End
        End If
        
        With ActiveWorkbook.SlicerCaches("スライサー_貼り付けルール")
            For Each selectItem In .SlicerItems
                If selectItem.Selected = True Then
                    opt2SelCnt = opt2SelCnt + 1
                    PasteOpt2 = selectItem.Value
                End If
            Next
        End With
        
        If opt2SelCnt <> 1 Then
            MsgBox WMsg2, vbExclamation
            End
        End If
        
    '    End If
    End Sub
    
    '-------------------------
    'コピー元情報のチェック
    '-------------------------
    Private Sub CheckCopyInfo()
    
        'コピー元Excelファイルで指定されたファイルが存在しない場合はメッセージを表示する
        If CBookPathNm = "" Or Dir(CBookPathNm) = "" Then
            MsgBox WMsg3
            End
        End If
        Workbooks.Open (CBookPathNm), UpdateLinks:=1
        
        Set CopyBook = ActiveWorkbook
        
        'コピー元の「対象シート名」が空白じゃない場合、対象ファイル内に当該シートが存在するか確認する
        If CSheetNm <> "" Then
            
            Dim hasTgtSheet As Boolean
            Dim cWs As Worksheet
                
            For Each cWs In CopyBook.Worksheets
                If cWs.Name = CSheetNm Then hasTgtSheet = True
            Next cWs
            If hasTgtSheet = False Then
                MsgBox "「" & CopyBook.Name & "」には" & Msg1, vbInformation
                CopyBook.Close SaveChanges:=False
                End
            End If
        End If
    
    End Sub
    
    '-------------------------
    '貼り付け先情報のチェック
    '-------------------------
    Private Sub CheckPasteInfo()
    
        '貼り付け先Excelファイルで指定されたファイルが存在しない場合はメッセージを表示する
        If PBookPathNm = "" Or Dir(PBookPathNm) = "" Then
            MsgBox WMsg3
            End
        End If
        
        Workbooks.Open (PBookPathNm), UpdateLinks:=1
        Set PasteBook = ActiveWorkbook
        
        If PasteOpt2 = "左列から順に貼り付け" Then
        
            Dim tmpWs As Worksheet
            Dim hasTgtSheet As Boolean
                
            'シート名の指定がある場合は、指定されたシート名が存在するかを確認する
            If PSheetNm <> "" Then
                TgtSheetNm = PSheetNm
                
                For Each tmpWs In PasteBook.Worksheets
                    If tmpWs.Name = TgtSheetNm Then hasTgtSheet = True
                Next tmpWs
                
                If hasTgtSheet = False Then
                    MsgBox "「" & PasteBook.Name & "」には" & Msg1, vbInformation
                    CopyBook.Close SaveChanges:=False
                    End
                End If
                
            'シート名の指定がない場合は、ファイル名をシート名にする
            Else
                '拡張子無のファイル名を取得する
                TgtSheetNm = Left(Left(CopyBook.Name, InStrRev(CopyBook.Name, ".") - 1), 31)
                
                For Each tmpWs In PasteBook.Worksheets
                    If tmpWs.Name = TgtSheetNm Then hasTgtSheet = True
                Next tmpWs
                
                If hasTgtSheet = True Then
                    PasteBook.Worksheets(TgtSheetNm).Copy After:=PasteBook.Worksheets(TgtSheetNm)
                     
                    If PSheetNm <> "" Then
                        TgtSheetNm = PSheetNm
                    Else
                        TgtSheetNm = PasteBook.Worksheets(PasteBook.Worksheets.Count).Name
                    End If
                    Application.DisplayAlerts = False
                    PasteBook.Worksheets(TgtSheetNm).Delete
                    Application.DisplayAlerts = True
                End If
            
                'ツールを実行したExcelファイルに新規シートを作成する
                PasteBook.Sheets.Add After:=PasteBook.Sheets(PasteBook.Sheets.Count)
                PasteBook.Sheets(PasteBook.Sheets.Count).Name = TgtSheetNm
            End If
    
        End If
        
    End Sub
    
    '-------------------------
    '他Excelファイルの値を取得して、指定したExcelファイルに貼り付ける
    '-------------------------
    Sub CopyAndPasteInfo()
    
        Dim cTmpSheet As Worksheet
        Dim pSCell As String
    
        '対象ファイルの全シートを1つずつループして処理する
        For Each cTmpSheet In CopyBook.Worksheets
            
            If CSheetNm <> "" And cTmpSheet.Name <> CSheetNm Then
                GoTo Continue
            End If
            
            '貼り付けルールが「シート別に貼り付け」の場合
            If PasteOpt2 = "シート別に貼り付け" Then
            
                Dim pWs As Worksheet, hasTgtSheet As Boolean: hasTgtSheet = False
                For Each pWs In PasteBook.Worksheets
                    If pWs.Name = cTmpSheet.Name Then hasTgtSheet = True
                Next pWs
                
                If hasTgtSheet = False Then
                
                    '貼り付け先Excelファイルに新規シートを作成する
                    PasteBook.Sheets.Add After:=PasteBook.Sheets(PasteBook.Sheets.Count)
                    PasteBook.Sheets(PasteBook.Sheets.Count).Name = cTmpSheet.Name
                    
                End If
                
                TgtSheetNm = cTmpSheet.Name
                pSCell = PStartCell
    
            '貼り付けルールが「左から順に貼り付け」の場合
            Else
                
                Dim firstCol As Long
                Dim secondCol As Long
                Dim pRowNum As Long
                Dim pColNum As Long
                    
                If ProcessCnt = 0 Then
                    
                    pSCell = PStartCell
                    pRowNum = ActiveSheet.Range(PStartCell).Row
                    pColNum = ActiveSheet.Range(PStartCell).Column
                    firstCol = ActiveSheet.Range(CStartCell).Column
                    secondCol = ActiveSheet.Range(CEndCell).Column
                    
                Else
    
                    Dim difCol As Long: difCol = secondCol - firstCol
                    pColNum = pColNum + difCol + 1
                    
                    pSCell = Cells(pRowNum, pColNum).Address
                    
                End If
            End If
            
            cTmpSheet.Range(CStartCell & ":" & CEndCell).Copy
            
            Select Case PasteOpt1
            
                Case "全てを貼り付け"
                    PasteBook.Sheets(TgtSheetNm).Range(pSCell).PasteSpecial Paste:=xlPasteAll
                    
                Case "数式を貼り付け"
                    PasteBook.Sheets(TgtSheetNm).Range(pSCell).PasteSpecial Paste:=xlPasteFormulas
                    
                Case "値を貼り付け"
                    PasteBook.Sheets(TgtSheetNm).Range(pSCell).PasteSpecial Paste:=xlPasteValues
            End Select
            
            ProcessCnt = ProcessCnt + 1
            
    Continue:
        Next
        Workbooks(PasteBook.Name).Close SaveChanges:=True
        Workbooks(CopyBook.Name).Close SaveChanges:=False
    
    End Sub
    
    '==========================================================
    'コピー元ファイルと貼り付け先ファイルセルをダブルクリックした際に実行される処理
    '==========================================================
    Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
        
        Dim tmp As String
        Dim msg As String
        tmp = Cells(Target.Row, Target.Column).Address(ColumnAbsolute:=False, RowAbsolute:=False)
        
        If tmp = PASTE_BOOK_NAME_POINT Then
            msg = Msg5
        ElseIf tmp = COPY_BOOK_NAME_POINT Then
            msg = Msg4
        Else
            Exit Sub
        End If
        
        Dim filePath As String
        Dim fileName As String
    
        'Excelファイルを指定するダイアログの表示
        filePath = Application.GetOpenFilename(Filefilter:="Microsoft Excelブック,*.xls?", Title:=msg)
    
        If filePath <> "False" Then
            
            Range(tmp).Value = filePath
            
        'キャンセルが選択された場合はダイアログを閉じる
        Else
            Exit Sub
        End If
    
    End Sub

     

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

     

    5.「対象セル範囲の貼り付け実行」と記載された図形にメイン処理「Click_対象セルの貼り付け実行」のマクロを設定します。

     

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

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

     

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

     

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

     

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

     

    また、このような業務効率化できるツールを以下に一覧でまとめてありますので、ご興味のある方はご覧ください。

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

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

     

    【Excel VBA】指定したセル範囲の値を取得して、指定したExcelファイルに貼り付けるツール

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

     

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

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

     

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

    1. ヨシダ より:

      本日動作を確認できました!!慣れるまでに少し時間はかかりましたがとても素晴らしいVBAだと思います!Excelは他のブックやシートからデータを引用した際にデータ元を新しいデータと入れ替える時非常に不便です。VBAを全く使用してこなかった人は少し慣れないかもしれませんが、このサイトに書いてある通りに導入すれば直ぐに使えます。(仕組みを理解するのに10分くらい必要かも?)使い方は色々工夫次第でできると思いますので皆さん是非使ってみてください。
      ありがとうございました!!

      1. RH より:

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

        是非色々と使ってみてください!
        ツールの課題点として、UI/UXが納得いく出来になっていないのと、使い方の説明として動画で解説するよう改善したいと思います。

        感想大変ありがとうございます。また気になる点がありましたら気軽にコメントください。

    コメントを残す

    CAPTCHA