VBA・マクロツール

【知らなくても使える】指定したセル範囲の値を別Excelファイルに貼り付けるマクロツール(Excel VBA)

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

 

そのようなときに例えば、以下のような作業を繰り返してないでしょうか。

  1. データを取得したいExcelファイルを開く。
  2. 開いたExcelファイルの対象のシートにあるセル範囲を選択して、コピーする。
  3. 貼り付け先のExcelファイルを開く。
  4. 貼り付け先ファイルの対象のシートのセルを選択して、貼り付けをする。

このような単純作業を、毎月更新されるデータに対して、毎回手動でコピペ&コピペ&コピペ…をしていては、とても時間がかかってしまいます。

 

そんな場面で、大変な作業を効率化できる『指定したセル範囲の値を取得して、指定したExcelファイルに貼り付けるマクロツール』をExcelマクロで作成しました。

 

当記事にはマクロの元になるExcelファイルがダウンロード可能で、VBAのコードも記事内に記載がありますので、Excel VBAやマクロが良く分からないという方でもすぐに使用できます

当ツールを使用すれば定例業務の業務効率化が図れるかと思いますので、是非ご活用頂けたらと思います。

 

ツールの更新履歴

(2022年9月25日:更新) 
・ツール全体のUIを変更

 

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

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

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

 

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

 

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

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

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

 

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

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

※「セル位置」の指定は、列アルファベット、行番の順で入力します

 

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

 

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

 

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

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

 

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

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

 

留意事項

セルの指定ルール

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

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

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

 

使用する際の事前準備

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

 

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

 

準備の手順

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

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

 

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

 

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

 

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を用いた業務効率化を行うときに、以下の書籍が実際のVBAコードを書く際に参考になると思いますので、良かったらご参照ください。

 

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

 

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

 

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

 

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

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

【Excel VBA】指定したセル範囲の値を別Excelファイルに貼り付けるマクロツール

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

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

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

 

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

コメントはこちら

  1. ヨシダ より:

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

    • RH より:

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

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

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

COMMENT

メールアドレスが公開されることはありません。 が付いている欄は必須項目です