| |
> お世話になってます｡
>今回は､ブックを新規に作成し､元のブックのシートをコピーするマクロを作成しました｡
>そこで､いくつか思うように動作しない箇所があります｡
>どなたかいいアドバイスをいただけないでしょうか？
>過去ログからいろいろ調べて､ここまでは作成してみましたが､うまくいきません｡
>よろしくお願いします｡
>
>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
|
|
Hirofumi
- 05/8/15(月) 3:12 -
