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