| |
あんまりコードが気に入らないんだけど？
こんなかな？
「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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
