自分用メモ VBA Excelシートコピペ処理

概要

仕事でXlookup関数などで参照してデータを抜き出すExcelを作りたくなったのですが、帳票からデータを引っ張って来て参照元のシートを常に最新にする必要があったので更新処理をつくりました。

コード

ほとんどの処理が例外処理で、コピペの処理はFinally:手前の数行のみです。

Option Explicit


Sub UpdateBtn_Click()
    Dim outputWb As Workbook    ' このExcel
    Dim outputWs As Worksheet    ' データ出力先シート
    Dim sourcePass As String        ' 読取り元ファイルパス
    Dim updateWsName As String  ' 更新するシート名
    Dim sourceWb As Workbook    ' 読取り元ファイル
    Dim readWs As Worksheet    ' 読取り元ファイル
    Dim existFlg As Boolean
    
    On Error GoTo Finally
    ' 処理高速化
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .Cursor = xlWait
    End With
    
    ' 初期化
    existFlg = False
    Set outputWb = ThisWorkbook
    sourcePass = "C:\Users\homan\Desktop\個人情報データ.xlsx" ' データ元のファイルパス
    
    updateWsName = "個人情報データ"
    
    ' エラー処理（読取りファイルのパスが存在しない場合）
    If Dir(sourcePass) = "" Then
        MsgBox "読み取り先ファイルが存在しません。下記ファイルパスが存在するか確認してください。" & vbLf _
                    & "ファイルパス：" & sourcePass _
                    , vbCritical, "エラー"
        GoTo Finally
    End If
    
    ' エラー処理（読取りファイルパスと同じファイル名のものが開かれている場合）
    Dim wb As Workbook
    Dim openFileflg As Boolean
    openFileflg = False
    For Each wb In Workbooks
        If wb.Name = Dir(sourcePass) Then
            openFileflg = True
            Exit For
        End If
    Next wb
    If openFileflg = True Then
        MsgBox "開いているExcelファイル（" & Dir(sourcePass) & "）を閉じてから、更新ボタンを押してください。", vbCritical, "エラー"
        GoTo Finally
    End If
    
    ' 読取りファイル取得
    Set sourceWb = Workbooks.Open(sourcePass, ReadOnly:=True)
    
    ' エラー処理（読取りファイル内に指定のシート名がない場合）
    Dim ws As Worksheet
    For Each ws In sourceWb.Sheets
        If ws.Name = updateWsName Then
            existFlg = True
            Exit For
        End If
    Next ws
    If existFlg = False Then
        MsgBox "読み取り先ファイルに指定のシート名(" & updateWsName & ")がありません。", vbCritical, "エラー"
        GoTo Finally
    End If
    
    ' 読取り元のシート取得
    Set readWs = sourceWb.Worksheets(updateWsName)
    ' 出力先のシート取得
    Set outputWs = outputWb.Worksheets(updateWsName)
    
    ' 個人情報データシート削除
    outputWs.Cells.ClearContents
    ' コピペ処理
    readWs.UsedRange.Copy outputWs.Range("A1")

Finally:
    If Not sourceWb Is Nothing Then
        sourceWb.Close False
    End If
    With Application
        .Cursor = xlDefault
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub