Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


24681 / 76732 ←次へ | 前へ→

【57399】現在Activeとなっているシートを別ブックにコピーしたい
質問  左之  - 08/8/18(月) 14:28 -

引用なし
パスワード
   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

'    ****************************************************************


☆申し訳ありませんが、宜しくお願いいたします。

1 hits

【57399】現在Activeとなっているシートを別ブックにコピーしたい 左之 08/8/18(月) 14:28 質問
【57402】Re:現在Activeとなっているシートを別ブッ... ponpon 08/8/18(月) 19:18 発言
【57408】Re:現在Activeとなっているシートを別ブッ... 左之 08/8/19(火) 13:45 お礼

24681 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free