Excel VBA質問箱 IV

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

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


53885 / 76732 ←次へ | 前へ→

【27653】Re:ブックの新規作成とコピー
回答  Hirofumi  - 05/8/15(月) 3:12 -

引用なし
パスワード
   >  お世話になってます。
>今回は、ブックを新規に作成し、元のブックのシートをコピーするマクロを作成しました。
>そこで、いくつか思うように動作しない箇所があります。
>どなたかいいアドバイスをいただけないでしょうか?
>過去ログからいろいろ調べて、ここまでは作成してみましたが、うまくいきません。
>よろしくお願いします。
>
>1. ユーザーフォーム上に、保存用のファイル名を決めるTextboxがあります。
>2. コピーするシートを決定するためのCheckboxが4つあります。
>3. 実行するためのCommandbuttonがあります。
>
>問題1
>Textbox1の内容が、名前をつけて保存のファイル名に反映する方法が分かりません。
>いい方法があれば、教えてください。
>
>問題2
>どうも、コピーされていません。というか、元ファイルのファイル名が変更されているだけ
>のような気がします。
>どうすれば良いでしょうか?

尚、UserForm上には、もう一つCommandButton2を配し、此れをTextBox1の保存名変更用とします
以下をUserFormのコードモジュールに記述して下さい

Option Explicit

'CheckBoxの数
Const lngBoxCount As Long = 4

'CheckBoxで選択されるシート名
Private vntCopySheets As Variant
'FileSystemObjectの参照を保存
Private objFso As Object

Private Sub UserForm_Initialize()

  'CheckBoxで選択するSheet名を設定
  vntCopySheets = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
  
  'TextBox1に保存名の初期値を設定
  TextBox1.Text = ThisWorkbook.Path & "\" & "作業報告書.xls"
  
  'FileSystemObjectを作成
  Set objFso = CreateObject("Scripting.FileSystemObject")

End Sub

Private Sub UserForm_Terminate()

  'FileSystemObjectを破棄
  Set objFso = Nothing
  
End Sub

Private Sub CommandButton1_Click()

  BookSave
'  Unload Me
  
End Sub

Private Sub CommandButton2_Click()

'  TextBox1の保存名変更

  Dim vntFileName As Variant
  Dim strPath As String
  
  vntFileName = TextBox1.Text
  '保存ダイアログを表示
  If GetWriteFile(vntFileName, strPath) Then
    TextBox1.Text = vntFileName
  End If
  
End Sub

Private Sub BookSave()

  Dim i As Long
  Dim vntFileName As Variant
  Dim strPath As String
  Dim wkbSave As Workbook
  Dim wkbFrom As Workbook
  Dim strProm As String
  
  vntFileName = TextBox1.Text
  If objFso.FileExists(vntFileName) Then
    strProm = "マクロの実行を中止します"
    Select Case MsgBox("同じ名前のファイルがあります。上書きしますか?", _
          vbYesNoCancel + vbInformation, "FileExists")
      Case vbNo
        '保存ダイアログを表示して、保存Book名を変更
        If GetWriteFile(vntFileName, strPath) Then
          TextBox1.Text = vntFileName
        Else
          If MsgBox("上書きしますか?", vbInformation _
                  + vbOKCancel, "上書") = vbCancel Then
            GoTo Wayout
          End If
        End If
      Case vbCancel
        GoTo Wayout
    End Select
  End If
  
  Application.ScreenUpdating = False
  
  'ActiveWorkbookの参照を取得
  Set wkbFrom = ActiveWorkbook
  
  'CheckBoxのシートを新規BookにCopy
  For i = 1 To lngBoxCount
    If Controls("CheckBox" & i) Then
      If wkbSave Is Nothing Then
        wkbFrom.Worksheets(vntCopySheets(i - 1)).Copy
        Set wkbSave = ActiveWorkbook
      Else
        With wkbSave
          wkbFrom.Worksheets(vntCopySheets(i - 1)).Copy _
              After:=wkbSave.Worksheets(.Worksheets.Count)
        End With
      End If
    End If
  Next i
  
  '新規Bookを名前を付けて保存
  If wkbSave Is Nothing Then
    strProm = "シートの選択が無いのでBookが作成されませんでした"
  Else
    Application.DisplayAlerts = False
    With wkbSave
      .SaveAs FileName:=vntFileName
      .Close
    End With
    Application.DisplayAlerts = True
    strProm = "処理が完了しました"
  End If
  
Wayout:
  
  Application.ScreenUpdating = False
  
  Set wkbSave = Nothing
  Set wkbFrom = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

Private Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String
  
  'フィルタ文字列を作成
  strFilter = "Excel Book (*.xls),*.xls"
  '既定値のファイル名を設定
  strInitialFile = vntFileName
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  '「ファイルを保存」ダイアログを表示
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 1)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True
  
End Function
1 hits

【27650】ブックの新規作成とコピー たかし 05/8/14(日) 22:09 質問
【27651】Re:ブックの新規作成とコピー ponpon 05/8/14(日) 23:41 発言
【27653】Re:ブックの新規作成とコピー Hirofumi 05/8/15(月) 3:12 回答
【27654】Re:ブックの新規作成とコピー たかし 05/8/15(月) 10:23 質問
【27656】Re:ブックの新規作成とコピー たかし 05/8/15(月) 10:34 質問
【27663】Re:ブックの新規作成とコピー Hirofumi 05/8/15(月) 12:43 回答
【27666】Re:ブックの新規作成とコピー たかし 05/8/15(月) 13:12 質問
【27667】Re:ブックの新規作成とコピー Hirofumi 05/8/15(月) 14:31 回答
【27669】Re:ブックの新規作成とコピー たかし 05/8/15(月) 15:03 お礼

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