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

Option Explicit

'-----（設定値）------------------------
Private Const COPY_START_CELL_POINT = "D17"         '１．設定シート内のコピーする開始セル位置
Private Const COPY_END_CELL_POINT = "E17"           '２．設定シート内のコピーする終了セル位置
Private Const COPY_SHEET_NAME_POINT = "D21"         '３．設定シート内のコピーするシート名のセル位置
Private Const PASTE_CELL_POINT = "J17"              '４．設定シート内の貼り付けする開始セル位置
Private Const PASTE_OPT1_POINT = "N25"              '５．設定シート内の貼り付けする開始セル位置
Private Const PASTE_OPT2_POINT = "O25"              '６．設定シート内の貼り付けする開始セル位置
Private Const MULTI_FILE_SHEET_NAME = "統合"        '７．「同階層の全ファイルを対象」かつ「左列から順に貼り付け」で実行した際のシート名
Private Const COPY_BOOK_NAME_POINT = "E7"           '８．コピー元Excelファイルを指定するセル位置
Private Const PASTE_BOOK_NAME_POINT = "E10"         '９．貼り付け先Excelファイルを指定するセル位置
Private Const PASTE_SHEET_NAME_POINT = "J21"        '１０．貼り付け先シート名のセル位置（「左列から順に貼り付け」時のみ指定可能"

'-----（メッセージ）--------------------
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