【Excel】別ブックからシートをコピペするExcelVBA雛形

2020年7月14日2022年9月9日

２つのブックを開いて、Access投入用に１つのブックに纏める

①今VBAを書いているExcelブックが親になる。

②コピペしたい別のブックを読み取り専用で開く。

③コピペしたいシートまたはセル値をコピペする。

プログラムというのは、基本的に動きを理解しないと使えないか？というと既に出来上がっているモノは既に動作確認が取れている場合がほとんでなので、案外そのまま使える。今回のように２つ以上のブックを開いて１つのブックに纏めるというのは、自分でコツコツ組み立てるよりも既に動いている自作関数やモジュールを組み合わせて、パターン化しておくと次回のプログラミングの時間短縮になる。

２つのブックを開いて、Access投入用に１つのブックに纏めておくなんてことは、これからもExcelVBAを使う場合、あらゆる場面で役に立つと思うよ♡

① 今VBAを書いているExcelブックが親になる

ThisWorkbook.Activate

この一文でシート間でのコピペ同様に処理ができる。初めはパターン例文そのままコピペして動作確認さえすれば良い。たくさんプログラムを組めばそのうち内容は理解できる。パターン例文は私が毎週JRAホームページから出走表とレース結果をAccess投入用に日付別のExcelファイルからデータをコピペしデータベースに投入しているものを参考に載せている。

②コピペしたい別のブックを読み取り専用で開く

ブックOpen判定

Function IsBookOpened(a_sFilePath) As Boolean
    On Error Resume Next
    
    '// 保存済みのブックか判定
    Open a_sFilePath For Append As #1
    Close #1
    
    If Err.Number > 0 Then
        '// 既に開かれている場合
        IsBookOpened = True
    Else
        '// 開かれていない場合
        IsBookOpened = False
    End If
End Function

③コピペしたいシートまたはセル値をコピペする

※「ここから処理を書く」～「ここまで処理」の部分を記入する。

別ブックからシートをコピペする雛形

Function OpenBk(opPath As String) As Variant
    Dim ex      As Excel.Application        	'// 処理用Excel
    Dim wb      As Workbook                 	' コピーするために開いたブック
    Dim sPath   As String                   	'// ブックファイルパス
    Dim r       As Range                    	'// 取得対象のセル範囲
    Dim sht     As Worksheet                	'// 参照シート
    Dim bFlg    As Boolean

   
    OpenBk = False
    '// 開くブックを指定（コピーしたいデータが入っている方）
    sPath = opPath
    
    '// 既に開かれているか確認
    bFlg = IsBookOpened(sPath)
    
    '// 開かれている場合
    If bFlg Then
        Set ex = New Excel.Application
        '// 新規Excelで読み取り専用で開く
        Set wb = ex.Workbooks.Open(Filename:=sPath, _
            UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
    Else
        '// 現ブックで読み取り専用で開く
        Set wb = Workbooks.Open(Filename:=sPath, _
            UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
    End If
    
    ThisWorkbook.Activate   'ここでコレを入れないとちゃんとコピペしないから！

※このVBA処理を書いているモジュールを含むブックがThisWorkbookになる！

'''　「ここから処理を書く」
'''※ これはやりたい処理を通常通りセル間の処理でかけば良い。



'''　「ここまで処理」

  '// ブックを閉じる
    Call wb.Close
    If bFlg = True Then
        Call ex.Application.Quit
    End If
    
    OpenBk = True
End Function

私が使っているサンプル例文も載せておく

※シート名やデータを揃え環境を同じにしないと、この例文だけでは動作しないが、利用方法の参考にはなると思う。

Function OpenBk(opPath As String) As Variant
    Dim ex      As Excel.Application        	'// 処理用Excel
    Dim wb      As Workbook                 	' コピーするために開いたブック
    Dim sPath   As String                   	'// ブックファイルパス
    Dim r       As Range                    	'// 取得対象のセル範囲
    Dim sht     As Worksheet                	'// 参照シート
    Dim bFlg    As Boolean

   
    OpenBk = False
    '// 開くブックを指定（コピーしたいデータが入っている方）
    sPath = opPath
    
    '// 既に開かれているか確認
    bFlg = IsBookOpened(sPath)
    
    '// 開かれている場合
    If bFlg Then
        Set ex = New Excel.Application
        '// 新規Excelで読み取り専用で開く
        Set wb = ex.Workbooks.Open(Filename:=sPath, _
        UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
    Else
        '// 現ブックで読み取り専用で開く
        Set wb = Workbooks.Open(Filename:=sPath, _
        UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
    End If
    
    ThisWorkbook.Activate   'ここでコレを入れないとちゃんとコピペしないから！

'''　「ここから処理を書く」
	
'''[出走RH][出走D]をコピペ
'    Dim Gyo1  As Integer                     	'出走RHの最終行
'    Dim Gyo2  As Integer                     	'出走Dの最終行
'    Dim int1 As Integer, int2 As Integer

    Gyo1 = 0
    Gyo2 = 0
    
    For int1 = 1 To 10000
        If Sheets("出走RH").Cells(int1 + 1, 1) = "" Then Exit For
        Gyo1 = int1
    Next int1
    For int1 = 1 To 10000
        If Sheets("出走D").Cells(int1 + 1, 1) = "" Then Exit For
        Gyo2 = int1
    Next int1
   
    '// 各シート「出走RH」取得
    For Each sht In wb.Worksheets
        If sht.Name = "出走RH" Then
            For int1 = 1 To 13
                For int2 = 1 To 14
                    Sheets("出走RH").Cells(Gyo1 + int1 + 1, int2) = _
                    sht.Cells(int1 + 1, int2)
                Next int2
            Next int1
        End If
        If sht.Name = "出走D" Then
            For int1 = 1 To 500
                If sht.Cells(int1 + 1, 1) = "" Then Exit For
                For int2 = 1 To 35
                    Sheets("出走D").Cells(Gyo2 + int1 + 1, int2) = _
                    sht.Cells(int1 + 1, int2)
                Next int2
            Next int1
        End If
    Next
    
    '''出走Dをコピペ

'''　「ここまで処理」
    
    '// ブックを閉じる
    Call wb.Close
    If bFlg = True Then
        Call ex.Application.Quit
    End If
    
    OpenBk = True
End Function
 
'// ブックオープン判定関数
Function IsBookOpened(a_sFilePath) As Boolean
    On Error Resume Next
    
    '// 保存済みのブックか判定
    Open a_sFilePath For Append As #1
    Close #1
    
    If Err.Number > 0 Then
        '// 既に開かれている場合
        IsBookOpened = True
    Else
        '// 開かれていない場合
        IsBookOpened = False
    End If
End Function