Excel VBA質問箱 IV

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

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


53871 / 76732 ←次へ | 前へ→

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

引用なし
パスワード
   あんまりコードが気に入らないんだけど?
こんなかな?

「Sub BookSave」だけが、変更に成りますので入換えて下さい

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
  Dim lngCount As Long
  
  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のTrueの数(シート数)を取得
  For i = 1 To lngBoxCount
    If Controls("CheckBox" & i) Then
      lngCount = lngCount + 1
    End If
  Next i
  'Copyするシートが有るなら
  If lngCount > 0 Then
    '新規Bookを追加
    Set wkbSave = Workbooks.Add
    '新規Bookのシート数が必要数以下ならシートを追加
    With wkbSave.Worksheets
      If .Count < lngCount Then
        .Add After:=.Item(.Count), Count:=lngCount - .Count
      End If
    End With
  End If
  'CheckBoxのシートを新規BookにCopy
  lngCount = 0
  With wkbSave
    For i = 1 To lngBoxCount
      If Controls("CheckBox" & i) Then
        lngCount = lngCount + 1
        wkbFrom.Worksheets(vntCopySheets(i - 1)).UsedRange.Copy
        With .Worksheets(lngCount)
          .Cells(1, "A").PasteSpecial _
              Paste:=xlFormats, Operation:=xlNone, _
              SkipBlanks:=False, Transpose:=False
          .Cells(1, "A").PasteSpecial _
              Paste:=xlValues, Operation:=xlNone, _
              SkipBlanks:=False, Transpose:=False
          Application.CutCopyMode = False
          .Activate
          .Cells(1, "A").Select
          On Error Resume Next
          .Name = vntCopySheets(i - 1)
          On Error GoTo 0
        End With
      End If
    Next i
  End With
  
  '新規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
0 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 お礼

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