|
▼おかちゃん さん:
おはようございます。
サンプルコードは以下のとおりです。
Sub sample()
Dim Wrbk As Object
Dim row As Integer
Worksheets.Add.Name = "サンプル"
Set Wrbk = Application.Workbooks.Open("C:\test用\01001.xls")
Wrbk.Worksheets("01001").Range("A1:H3").Select
Selection.Copy
Workbooks("Book1.xls").Activate '現在使用しているエクセルの名前
Sheets("サンプル").Range("A1").Select
Selection.PasteSpecial
Application.CutCopyMode = False
Wrbk.Close False
Set Wrbk = Nothing
Set Wrbk = Application.Workbooks.Open("C:\test用\01002.xls")
Wrbk.Worksheets("01002").Range("A1:H6").Select
Selection.Copy
Workbooks("Book1.xls").Activate '現在使用しているエクセルの名前
Sheets("サンプル").Select
row = 1
Do Until Cells(row, 1) = ""
row = row + 1
Loop
Cells(row, 1).Select
Selection.PasteSpecial
Application.CutCopyMode = False
Wrbk.Close False
Set Wrbk = Nothing
Set Wrbk = Application.Workbooks.Open("C:\test用\01003.xls")
Wrbk.Worksheets("01003").Range("A1:H5").Select
Selection.Copy
Workbooks("Book1.xls").Activate '現在使用しているエクセルの名前
Sheets("サンプル").Select
row = 1
Do Until Cells(row, 1) = ""
row = row + 1
Loop
Cells(row, 1).Select
Selection.PasteSpecial
Application.CutCopyMode = False
Wrbk.Close False
Set Wrbk = Nothing
Worksheets("サンプル").Activate
ActiveSheet.PageSetup.PrintArea = "" '印刷範囲クリア
ActiveWindow.SelectedSheets.PrintPreview '印刷プレビュー表示
Application.DisplayAlerts = False '削除確認メッセージ非表示
ThisWorkbook.Worksheets("サンプル").Delete
Application.DisplayAlerts = True '削除確認メッセージ表示
End Sub
これで動くと思います。
もしサンプルシートを削除したくなかった場合は
最後の3行を消すかコメントにしてください。
|
|