| |
Excell2010にコマンドボタンを設定し、”Cmd発注”をクリックすると、必要なメインのExcellシートだけをメイン画面の”実績”フォルダに作成したいです。。。
ではありますが、現状では全く意図していないところに
新しく作成したシートが出来ちゃいます。。。。
どう修正すればよいのか。ご指導よろしくお願いいたします。
Sub Cmd発注()
Dim i As Single
Dim Iret As Single
Dim Size As Single
Dim lReturn As Long
Dim ActiveFile As String
Dim SaveFile, SaveFile1, Hinichi As String
Dim OpenFile_Name As String
Dim OpenFile_Name_Dir As String
'問い合せﾀﾞｲｱﾛｸﾞの表示をOFFにします
Application.DisplayAlerts = False
'依頼No.作成
OpenFile_Name = ActiveWorkbook.Path
File購入依頼書 = Sheets("治工具").Range("H6").Value
Range("H6").Select
Selection.UnMerge
Range("H6").Select
Selection.Copy
Range("P6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P6").Select
ActiveCell.FormulaR1C1 = "=SUBSTITUTE(RC[-8],""/"","""")"
File購入依頼書 = ActiveCell.Value
'保存
Sheets("治工具").Select
Range("A8").Select
Sheets("治工具").Copy After:=Sheets(4)
ActiveSheet.Name = File購入依頼書
ActiveFile = ActiveSheet.Name
Sheets(File購入依頼書).Select
Sheets(File購入依頼書).Copy
'ﾌｫﾙﾀﾞ名がなければ作成する
OpenFile_Name_Dir = OpenFile_Name & "\実績\" 'Openフォルダ名取得
If Dir(SaveDir, vbDirectory) = "" Then
MkDir "実績"
MkDir OpenFile_Name_Dir
End If
ActiveWorkbook.SaveAs _
FileName:=File購入依頼書 & "xls"
Hinichi = File購入依頼書
Size = Len(File購入依頼書) 'フルパス名長
SaveFile = OpenFile_Name_Dir & File購入依頼書 & ".xlsx" '保存ファイル名創生
Workbooks(1).Activate
Sheets(File購入依頼書).Select
Sheets(File購入依頼書).Delete
Workbooks(2).Activate
Size = Len(SaveFile) 'フルパス名長
For i = Size To 1 Step -1
If Mid(SaveFile, i, 1) = "\" Then
SaveFile1 = Right(SaveFile, Size - i) 'Openフルパス名取得
Exit For
End If
Next i
Range("A8").Select
Retry:
Iret = MsgBox("『" & SaveFile & "』 で保存しますが、宜しいですか？" & vbCrLf + vbLf & "フォルダーを変更する場合は『いいえ』を選択して下さい。", vbQuestion + vbYesNo)
If Iret = vbYes Then
Exit Sub
Else
lReturn = Application.Dialogs(xlDialogSaveAs).Show(arg1:=SaveFile1, arg2:=18)
'保存画面 document_text、type_num、prot_pwd、backup、write_res_pwd、read_only_rec
If lReturn = False Then 'CanselならばRetryに戻る
GoTo Retry
End If
End If
GoTo FIN
CHK:
If Err.Number = 76 Then 'Pathが存在しない場合にフォルダー作成
MkDir OpenFile_Name & File購入依頼書
Else
MsgBox (Err.Description)
End If
Resume Next
'問い合せﾀﾞｲｱﾛｸﾞの表示をONに戻します
Application.DisplayAlerts = True
'発注Skip:
FIN:
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
