|
こんばんは。
できるだけ、提示のコードを生かすようにしました。
もっと良い方法があると思います。
試してください。
フォームモジュールに
Private Sub CommandButton1_Click()
Dim myWB As Workbook
Set myWB = Workbooks.Add
If Me.CheckBox1.Value = True Then
myWB.Sheets(1).Name = "データシート"
Workbooks("作業報告書_保存.xls").Sheets("データシート").Cells.Copy _
myWB.Sheets("データシート").Range("A1")
Call 保存
ElseIf Me.CheckBox2.Value = True Then
' 以下、同様にCheckBox2、CheckBox3、CheckBox4でシート2・3・4をコピーする
End If
End Sub
標準モジュールに
Sub 保存()
Dim savPath As Variant
Dim fName As String
Dim a As Integer, b As Integer
Application.DisplayAlerts = False
' savPath = Application.GetSaveAsFilename( _
' InitialFileName:="作業報告書.xls", _
' FileFilter:="Excelファイル (*.xls), *.xls,すべてのファイル(*.*),*.*")
If UserForm1.TextBox1.Text <> "" Then
savPath = UserForm1.TextBox1.Text & ".xls"
fName = Dir(ThisWorkbook.Path & savPath)
If fName <> "" Then
a = MsgBox("同じ名前のファイルがあります。上書きしますか?", vbYesNoCancel)
Select Case a
Case 6 'OK
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & savPath
Unload UserForm1
ActiveWorkbook.Close
Exit Sub
Case 7 'NO
Case 2 'Cancel
Exit Sub
End Select
Else
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & savPath
Unload UserForm1
ActiveWorkbook.Close
Exit Sub
End If
Else
MsgBox "ファイル名がありません。"
UserForm1.TextBox1.SetFocus
Exit Sub
End If
End Sub
|
|