[[20150423181803]] 『VBAでシート作成』(rinrin) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『VBAでシート作成』(rinrin)

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

'依頼?m?成

    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

< 使用 Excel:Excel2010、使用 OS:Windows7 >


以下は余分かと。
       MkDir "実績"

あと、以下のようにセットしたファイル名ですが、

    File購入依頼書 = Sheets("治工具").Range("H6").Value

数行下で、以下に変わってます。

    File購入依頼書 = ActiveCell.Value

で、ご質問の保存場所ですが、

    ActiveWorkbook.SaveAs _
        FileName:=File購入依頼書 & "xls"

この部分で、フォルダを指定していないせいでは?
(???) 2015/04/23(木) 18:54


質問したとたんに回答。。。。。。。。。。ありがとうございます。。。

今すぐには確認はとれないのですが、とりいそぎお礼を伝えたくて返事を書きました。。。

ホントにありがとうございます。。。;;

またわからなくなったとき お助けいただけたら幸いです。。。^^
ありがとうございました。。。。。。。。。^^
(rinrin) 2015/04/23(木) 20:29


一応こちらにも。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=76978;id=excel
(マルチネス) 2015/04/24(金) 08:16


こちらも。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=76989;id=excel
(マルチネス) 2015/04/25(土) 00:14


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.