【EXCEL VBA】ユーザーフォームを利用した①ファイルを開いて、②指定したシートを自分自身にコピーさせる処理の自動化のサンプル

ユーザーフォームを利用した①ファイルを開いて、②指定したシートを自分自身にコピーさせる処理の自動化のサンプル

ワークシートの指定を簡単化するため、リストボックスを利用している。

このサンプルコードを実行するには、ユーザーフォームにリストボックスを張り付ければOK

UserForm1

Private m_OpenFileName As String
Private m_OpenWorkBook  As Workbook
Private m_OpenWorksheet  As Worksheet
Private Const COPY_SHEET As String = "コピー先シート"

‘①ファイルを開いて、②指定したシートを自分自身にコピーさせる処理

Private Sub ListBox1_Click()
    Dim TmpWrokSheet As Worksheet
    Application.DisplayAlerts = False
    If ListBox1.ListIndex = -1 Then Exit Sub
   
    Set m_OpenWorkBook = Workbooks.Open(m_OpenFileName)
    Set m_OpenWorksheet = m_OpenWorkBook.Worksheets(ListBox1.Text)
   
‘    MsgBox m_OpenWorksheet.Name
   
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name = COPY_SHEET Then ws.Delete
    Next ws
    Set TmpWrokSheet = ThisWorkbook.Worksheets.Add
    TmpWrokSheet.Name = COPY_SHEET
       
    m_OpenWorksheet.Cells.Copy TmpWrokSheet.Cells
   
    GoTo FINALLY
EXCEPTION:

FINALLY:
    If Not m_OpenWorkBook Is Nothing Then
        m_OpenWorkBook.Close
        Set m_OpenWorkBook = Nothing
    End If
     Application.DisplayAlerts = True
    Me.Hide
End Sub

‘①フォーム初期化でファイルを開き、シート名一覧を取得する。
Private Sub UserForm_Initialize()
    On Error GoTo EXCEPTION
    Dim ws As Worksheet
   
    m_OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
    Set m_OpenWorkBook = Workbooks.Open(m_OpenFileName)
   
    ListBox1.Clear
    For Each ws In m_OpenWorkBook.Worksheets
        ListBox1.AddItem ws.Name
    Next ws
   
    GoTo FINALLY
EXCEPTION:

FINALLY:
    If Not m_OpenWorkBook Is Nothing Then
        m_OpenWorkBook.Close SaveChanges:=False
        Set m_OpenWorkBook = Nothing
    End If
End Sub

標準モジュール側（サンプル）

Sub test1()

    UserForm1.Show   
End Sub