Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

5367 / 76732

←次へ　｜　前へ→


	【76978】VBAでシートを作成

rinrin - 15/4/23(木) 18:13 -


	引用なし

	パスワード

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

232 hits

▼

【76978】VBAでシートを作成 rinrin 15/4/23(木) 18:13