| |
VBA初心者です。お世話になります。
☆以下の要求を満たすVBAコードについて、アドバイスを頂けたらと思います。
※要求1. 現在Activeとなっているシートを別ブックにコピーしたい(Excel)
・要求2. 別ブック(コピー先のブック)は新規作成したい
・要求3. 別ブック(コピー先のブック)を開きたくはない
・要求4. Activeシートの罫線、背景色などもコピーしたい
☆私が作成したコードを記します（多少簡略化しています）
⇒問題点 ： 要求4.を満たしていない
気になる点： シートではなく、セルでコピーしている
' ****************************************************************
Sub SheetCopy()
Dim SaveSheetName As String
Dim EstimateBookName As Variant
Dim myYN As Boolean
Dim SoftName
Dim Psw As String
Dim objFS As Object
Dim objExcel As Object
SaveSheetName = "保存するするシート"
FileName = "保存するファイル名(デフォルト)"
'以下、要求2.を満たす部分
'見積ファイル名の指定
EstimateBookName = Application.GetSaveAsFilename(InitialFileName:=FileName, FileFilter:="Excel ファイル (*.xls), *.xls")
If EstimateBookName = False Then Exit Sub
'同名ファイルのチェック
If Dir(EstimateBookName) <> "" Then '同名ファイルが存在しない場合は、Dir関数で""が返る
'上書きの警告を表示する
myYN = MsgBox("同名のファイルがすでに存在します。" & Chr(13) & "上書きしてもよろしいですか？", vbYesNo + vbExclamation)
If myYN = vbNo Then Exit Sub
End If
'以下、要求1. 要求3.を満たす部分
'(要求4.も満たしたかったのですが、出来ませんでした…)
Sheets(SaveSheetName).Activate
'Excelが表示する上書き警告画面を抑止する
Application.DisplayAlerts = False
'新しいBook(見積Book)を作成し、見積をコピーする
'その際、要らない部分は非表示にする
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objExcel = objFS.CreateTextFile(EstimateBookName, True)
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open FileName:=EstimateBookName
objExcel.Visible = False '要求3.部
objExcel.Workbooks(1).Worksheets(1).Select
ActiveSheet.Cells.Select '要求4.が実現しなかった原因と思われる箇所
Selection.Copy
objExcel.Workbooks(1).Worksheets(1).Select
objExcel.Workbooks(1).Worksheets(1).Paste
ActiveSheet.Cells(1, 1).Select
'見積シート作成終了＝閉じる
objExcel.Workbooks(1).Close SaveChanges:=True
objExcel.Quit
End Sub
' ****************************************************************
☆申し訳ありませんが、宜しくお願いいたします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
