Option Explicit
Sub 別ブックのすべてのセルを取得2()
Dim startTime As Double
Dim middleTime As Double
Dim processTime As Double
startTime = Timer '開始時間取得
Application.ScreenUpdating = False '画面描画を停止
Application.EnableEvents = False 'イベントを抑止
Application.DisplayAlerts = False '確認メッセージを抑止
Application.Calculation = xlCalculationManual '計算を手動に
Dim Excel As New Application
'エクセルを不可視で開く
Excel.Visible = False 'エクセル可視/不可視設定
Excel.DisplayAlerts = False '警告メッセージをオフ
'------------------------------------------------------------------------ここまで
'↑ここまでは上記サンプルコードと同一↑
'メイン処理0の時間をイミディエイトウィンドウに出力
middleTime = Timer
processTime = middleTime - startTime
Debug.Print "メイン処理0の終了:"; processTime & "秒" & vbCrLf
'Call メイン処理0の終了
Dim ws As Worksheet
Dim filename As String
Dim mb As Workbook
'貼り付け先のブック
filename = ThisWorkbook.path & "\" & "ワークシート.xlsm"
Set mb = Workbooks.Open(filename)
'------------------------------------------------------------------------1ここから
Dim FullPath1 As String, FullPath2 As String, FullPath3 As String, FullPath4 As String
FullPath1 = "C:\Users\名前\Desktop\Excelフォルダ" & "\" & "配信スケジュール .xlsm" ' "救急患者集計.xlsm"
FullPath2 = "C:\Users\名前\Desktop\Excelフォルダ" & "\" & "未納本文.xlsm" ' "救急患者集計.xlsm""未納整理簿.xlsm"
FullPath3 = "C:\Users\名前\Desktop\Excelフォルダ" & "\" & "未納本文.xlsm" ' "救急患者集計.xlsm""未納整理簿.xlsm"
FullPath4 = "C:\Users\名前\Desktop\Excelフォルダ" & "\" & "未納本文.xlsm" ' "救急患者集計.xlsm""未収金折衝状況表.xlsm"
FullPath1 = "D:\goo\excel\goo446\配信スケジュール.xlsm"
FullPath2 = "D:\goo\excel\goo446\未納本文.xlsm"
FullPath3 = "D:\goo\excel\goo446\未納本文.xlsm"
FullPath4 = "D:\goo\excel\goo446\未納本文.xlsm"
Dim Fullpath As Variant
Dim Frsheet As Variant
Dim Tosheet As Variant
Dim Title As Variant
Dim i As Long
Fullpath = Array(FullPath1, FullPath2, FullPath3, FullPath4)
Frsheet = Array("sheet5", "未納本文", "全部1", "未納本文")
Tosheet = Array("kyu", "nyu", "gai", "折衝取込")
Title = Array("未納本文処理1の終了:", "全部1処理2の終了:", "未納本文処理3の終了:", "全部1をふくめた完了までの所要時間:")
For i = 0 To 3
Call copy_sheet(Excel, Fullpath(i), Frsheet(i), mb, Tosheet(i))
middleTime = Timer
processTime = middleTime - startTime
Debug.Print Title(i); processTime & "秒" & vbCrLf
Next
Application.Calculation = xlCalculationAutomatic '計算を自動に
Application.DisplayAlerts = True '確認メッセージを開始
Application.EnableEvents = True 'イベントを開始
Application.ScreenUpdating = True
Excel.DisplayAlerts = True '警告メッセージをオン
Excel.Quit 'Excel終了
Set Excel = Nothing '参照を解放
MsgBox "書き換えました"
End Sub
Private Sub copy_sheet(ByRef Excel As Application, ByVal Fullpath As String, ByVal Frsheet As String, ByRef mb As Workbook, ByVal Tosheet As String)
Dim Fwb As Workbook
Dim SourceRng As Range
Dim TargetRng As Range
Set Fwb = Excel.Workbooks.Open(Fullpath, ReadOnly:=True) '読取り専用で開く
Set SourceRng = Fwb.Worksheets(Frsheet).UsedRange
mb.Worksheets(Tosheet).Cells.Clear
Set TargetRng = mb.Worksheets(Tosheet).Range("A1")
SourceRng.Copy
TargetRng.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
TargetRng.PasteSpecial Paste:=xlPasteColumnWidths
Application.CutCopyMode = False
Fwb.Close
End Sub