- ベストアンサー
VBAを使って名前をつけて保存をしたい(2)
pkh4989の回答
連番をテキストファイルに保存して管理する例です。 参考にしてください。 Sub 名前を付けて保存() Dim wSeq As String Dim wStr As String Dim Flnm As String Dim wFlnm As String Dim sI As Integer Dim eI As Integer Dim wDir As String Dim ER As Boolean ' Sheets("データー").Select Range("C3").Select ActiveWorkbook.Save wDir = "\\Jooo\センタ\AA\CC\" Flnm = wDir & Format(Date, "【mmdd】") & ".xls" wFlnm = Flnm If Flnm = "False" Then Exit Sub End If ' wSeq = 0 wSeq = Get_Seq(wDir, ER) If ER Then wStr = "" Else wStr = "(" & wSeq & ")" End If Flnm = Left(wFlnm, Len(wFlnm) - 4) & wStr & ".xls" ActiveWorkbook.SaveAs Filename:=Flnm Call Put_Seq(wDir, wSeq) End Sub '連番取得 Function Get_Seq(wDir As String, ER As Boolean) As Integer Dim n As Long Dim Seq As Integer ' ER = False Seq = 0 On Error GoTo ExitER n = FreeFile Open wDir & "連番.dat" For Input As #n Input #n, Seq Close #n Get_Seq = Seq + 1 Exit Function ExitER: ER = True Seq = 1 On Error GoTo 0 End Function '連番保存 Function Put_Seq(wDir As String, wSeq As String) Dim n As Long n = FreeFile Open wDir & "連番.dat" For Output As #n Print #n, wSeq Close #n End Function
関連するQ&A
- VBAを使って名前をつけて保存をしたい(3)
Sub 名前を付けて保存() Dim wSeq As String Dim wStr As String Dim Flnm As String Dim wFlnm As String Dim sI As Integer Dim eI As Integer Dim wDir As String Dim ER As Boolean ' Sheets("データー").Select Range("C3").Select ActiveWorkbook.Save wDir = "\\Jooo\センタ\AA\CC\" Flnm = wDir & Format(Date, "【mmdd】") & ".xls" wFlnm = Flnm If Flnm = "False" Then Exit Sub End If ' wSeq = 0 wSeq = Get_Seq(wDir, ER) If ER Then wStr = "" Else wStr = "(" & wSeq & ")" End If Flnm = Left(wFlnm, Len(wFlnm) - 4) & wStr & ".xls" ActiveWorkbook.SaveAs Filename:=Flnm Call Put_Seq(wDir, wSeq) End Sub '連番取得 Function Get_Seq(wDir As String, ER As Boolean) As Integer Dim n As Long Dim Seq As Integer ' ER = False Seq = 0 On Error GoTo ExitER n = FreeFile Open wDir & "連番.dat" For Input As #n Input #n, Seq Close #n Get_Seq = Seq + 1 Exit Function ExitER: ER = True Seq = 1 On Error GoTo 0 End Function '連番保存 Function Put_Seq(wDir As String, wSeq As String) Dim n As Long n = FreeFile Open wDir & "連番.dat" For Output As #n Print #n, wSeq Close #n End Function 先日回答者の方から上記を教えてもらったんですが、実行すると指定したフォルダに本日の日付＋連番の名称でどんどん保存されるんですが (例：一回目実行→【1028】,二回目実行→【1028】(1),三回目実行→【1028】(2),四回目実行→【1029】(3),五回目実行→【1029】(4),※四回目以降は明日に実行した場合です),日付が変わった場合連番を最初からカウントするようにしたいのですが(例の【1029】(3)を【1029】に,【1029】(4)を【1029】(1)というふうに)どの様に上記を変更したらいいでしょうか?
- ベストアンサー
- オフィス系ソフト
- VBAでわからなくなってしまったので質問します。
VBAでわからなくなってしまったので質問します。 初心者なのですが、下記の問題にあたってしまい困っています。 製品Aと製品B～ｘまでEXCEL2007で表を作ってあります。 A～ｘまで同じVBA構文を使っていますが、 Aは名前を付けて保存すると 製品名A2456【0506】と製品名+コード番号+年月になります。 しかし、B～ｘは製品名B～Xのみがファイル名になってしまいます。 構文A～ｘともRangeの参照以外共通で下記です。 Sub 最終保存() Dim wSeq As String Dim wStr As String Dim Flnm As String Dim wFlnm As String ' Flnm = "C:\Documents and Settings\user\My Documents\受検ファイル\受検済み\" '←保存先フォルダ Flnm = Flnm & Range("B11") & Range("G20") & Format(Range("B6"), "【mmdd】") '←保存ファイル名 Flnm = Application.GetSaveAsFilename(InitialFileName:=Flnm, _ filefilter:="Excel ファイル (*.xlsx), *.xlsx", Title:="名前を付けて保存") If Flnm = "False" Then Exit Sub End If ' wSeq = 0 ExitFlg = False wFlnm = Flnm Do While ExitFlg = False If Dir(Flnm) <> "" Then '存在したら、連番を加算 wSeq = wSeq + 1 wStr = "(" & wSeq & ")" Flnm = Left(wFlnm, Len(wFlnm) - 4) & wStr & ".xlsx" Else '存在しない時、保存 ActiveWorkbook.SaveAs Filename:=Flnm, FileFormat:=xlOpenXMLWorkbook ExitFlg = True End If Loop End Sub Rangeの「B11」が製品名、「G20」がコード番号、「B6」が2010年5月○日という日付になっています。 なお、最初のRange("B11")を取り除くとコード+日付がファイル名になります。 なぜ、製品Aは出来てB～ｘが出来ないのか分かりません。 アドバイスお願いします。
- ベストアンサー
- その他MS Office製品
- VBA 保存
保存ボタンを作成してファイルに飛ぶように させていますが…どうしてもエラーになります！ エラー表示内容＞ 実行時エラー１００４ シートの名前を他のシート、Visual Basicで参照される オブジェクト ライブラリまたは ワークシートと同じ名前に変更することはできません。 下記は実際の記述です。 Private Sub 保存_Click() Dim FileName As String Dim FileExt As String Dim BkName As String Dim OldWkbook As Workbook Dim NewWkbook As Workbook Const StName1 As String = "計画 グラフ" Const StName2 As String = "ケア一覧" ' Application.DisplayAlerts = False Set OldWkbook = ActiveWorkbook ' 'ファイル名を取得 BkName = OldWkbook.Sheets(StName1).Range("D1").Value FileName = BkName & Format(Now, "yyyy-mm-dd") & ".XLS" ' FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".XLS" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If ' OldWkbook.Sheets(Array(StName1, StName2)).Copy Set NewWkbook = ActiveWorkbook For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count NewWkbook.Sheets(1).Shapes(1).Delete '←シート1のボタンを削除 Next NewWkbook.Sheets(1).Name = StName1 NewWkbook.Sheets(2).Name = StName2 ' FileName = "D:\看護計画保存\" & FileName ' If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then NewWkbook.Close savechanges:=False '##保存せずに終了 Exit Sub End If '##指定ファイル置き換え保存 NewWkbook.SaveAs FileName:=FileName Else '##ファイルを新規保存 NewWkbook.SaveAs FileName:=FileName End If ' NewWkbook.Close savechanges:=False Application.DisplayAlerts = True End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルにて、VBAで名前を付けて保存する場合
こんにちは、色々試しているのですが、うまくいかずに悩んでいます。 コマンドを実行すると、名前を付けて保存のダイアログ画面を表示させるＶＢＡを作りたいです。 ただし、 (1)保存せずに、ダイアログを表示させる状態で停止させる。 (2)ダイアログ表示時、ファイル名欄に”売上集計表yyyy年mm月”というファイル名が入っている。（yyyyとmmは変数。コマンド実行時に入力する事でファイル名もそれに対応する。） 以下の様にVBAを組んだのですが（他にも色々組んでいますが、うまく動いている個所は省いてます。）、上記(1)(2)共に思い通りに動いてくれません。分かるかたがいましたら、よろしくお願いします。 Sub 保存() ' ' Macro1 Macro Dim rtn Dim myD As String, msg As String, fn As String, x As String Dim wb As Workbook, ws As Worksheet line: ' 年月の入力処理 rtn = Application.InputBox("入力する月を西暦YYYYMM形式で入力してください。" _ & vbNewLine & "例）2011年7月⇒201107", Type:=1) If rtn = False Then Exit Sub myD = Left(rtn, 4) & "/" & Right(rtn, 2) & "/01" If Not IsDate(myD) Then MsgBox "存在しない年月です！", vbCritical GoTo line Else If MsgBox(Format(myD, "yyyy年mm月") & "で間違いないですか？", vbYesNo + vbQuestion) = vbNo Then Exit Sub End If End If 'ファイルの保存 ChDir "C:\Users\（ユーザー名）\Desktop\新しいフォルダー" ActiveWorkbook.SaveAs Filename:= _ "C:\Users\（ユーザー名）\Desktop\新しいフォルダー\売上集計表保存" & "Year(myD)" & "年" & "Month(myD)" & "月" & ".xlsm", FileFormat:= _ xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False End Sub
- ベストアンサー
- オフィス系ソフト
- （VBA）特定のシートのみを名前を付けて保存
Excel2003です。 数シートあるうちの特定のシートのみを別のbookとして「名前を付けて保存」する下記のコードを書きました。一応うまく動くのですが、実はこの特定のシートには行の非表示部分があります。しかし、下記のコードではもちろん非表示部分も開かれた状態で保存がされますよね。 この非表示の状態で保存するにはどのようにすればよいのでしょうか？ 【以下現在のコードです】 ------------------------------------------------ Sub 名前を付けて保存() '報告書を"名前を付けて保存" Sheets("報告書").Select Dim 既定ファイル名 As String Dim 保存ファイル名 As Variant 既定ファイル名 = "報告書" 保存ファイル名 = Application.GetSaveAsFilename(既定ファイル名, "Excel ブック(*.xls),*.xls") If 保存ファイル名 = False Then MsgBox "保存は中止されました。" Else With ThisWorkbook.ActiveSheet Workbooks.Add .Cells.Copy ActiveSheet.Range("A1") ActiveWorkbook.SaveAs 保存ファイル名, xlNormal ActiveWorkbook.Close False End With Sheets("報告書").Select Range("A1").Select MsgBox "報告書を作成しました。" End If End Sub ----------------------------------------------------
- ベストアンサー
- オフィス系ソフト
- エクセル VBA シート保存ボタン
Sheet上にボタンを作成 ボタンを押すと保存するようにしています！ 以前ここでSheet2枚をコピー出来るような 記述教えてもらったのですが・・ 1枚ならどう変化して良いか・・ 記述を書きましたが 何処が違うか教えて下さい！ Private Sub CommandButton1_Click() Dim FileName As String Dim FileExt As String Dim BkName As String Dim OldWkbook As Workbook Dim NewWkbook As Workbook Const StName1 As String = "ko" ' Application.DisplayAlerts = False Set OldWkbook = ActiveWorkbook ' 'ファイル名を取得 BkName = OldWkbook.Sheets(StName1).Range("A1").Value FileName = BkName & Format(Now, "yyyy-mm") & ".XLS" ' FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".XLS" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If ' OldWkbook.Sheets(Array(StName1)).Copy Set NewWkbook = ActiveWorkbook For wIx = 1 To NewWkbook.Sheets(1).Shapes.Count NewWkbook.Sheets(1).Shapes(wIx).Delete Next NewWkbook.Sheets(1).Name = StName1 ' FileName = "D:\保存\計画\" & FileName ' If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then NewWkbook.Close savechanges:=False '##保存せずに終了 Exit Sub End If '##指定ファイル置き換え保存 NewWkbook.SaveAs FileName:=FileName Else '##ファイルを新規保存 NewWkbook.SaveAs FileName:=FileName End If ' NewWkbook.Close savechanges:=False Application.DisplayAlerts = True End Sub 教えて下さい！
- ベストアンサー
- オフィス系ソフト
- ActiveWorkBook VBA
Sub test() Dim myCSV As String Dim Fname As Variant Dim Aname As String Dim Fullp As String Application.ScreenUpdating = False Fullp = ActiveWorkbook.FullName Pos = InStrRev(Fullp, "\") Fname = Left(Fullp, Pos) myCSV = Dir(Fname & "*.csv") Do Until myCSV = "" Workbooks.Open Fname & myCSV Aname = Left(Fullp, InStr(1, Fullp, ".") - 1) ActiveWorkbook.SaveAs filename:=Aname & ".xls", FileFormat:=xlExcel9795 ActiveWorkbook.Close myCSV = Dir() Loop Kill Fname & "*.csv" End Sub あるフォルダにあるcsvファイルをxlsで保存したいと思いましたが、アクティブになるBOOKがバラバラ？ で、うまくいきません。csvファイルを開いたときに そのファイルがアクティブになり、うまくloopできないでしょうか？
- ベストアンサー
- オフィス系ソフト
- Excel2003のVBAでエクセルファイルとして保存
こんにちわ。 Excel2003のVBAで、シート1に採点用のフォーマットを作成し、採点ボタンを押したら別の場所（フォルダ）に別のファイル（.xls形式）として採点結果を保存したいと考えています。過去に似たような質問があったのでそれを参考にしたのですが、コードの意味がほとんど分かりません。下記のコードで実行したところ、エラーが出てしまいます。どこが悪いのか教えていただけないでしょうか？ エラー箇所は BkName = OldWkbook.Sheets(StName1).Range("K1").Value です。”インデックスが有効範囲にありません”と表示されます。 例） Dim FileName As String Dim FileExt As String Dim BkName As String Dim OldWkbook As Workbook Dim NewWkbook As Workbook Const StName1 As String = "ko" ' Application.DisplayAlerts = False Set OldWkbook = ActiveWorkbook ' 'ファイル名を取得 BkName = OldWkbook.Sheets(StName1).Range("K1").Value FileName = BkName & Format(Now, "yyyy-mm") & ".XLS" ' FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".XLS" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If ' OldWkbook.Sheets(Array(StName1)).Copy Set NewWkbook = ActiveWorkbook 'シートの保護を解除 Worksheets("sheet1").Unprotect For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1 If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除 NewWkbook.Sheets(1).Shapes(wIx).Delete '←1ではなくwIxです End If Next NewWkbook.Sheets(1).Name = StName1 ' FileName = "D:\保存\計画\" & FileName ' If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then NewWkbook.Close savechanges:=False '##保存せずに終了 Exit Sub End If '##指定ファイル置き換え保存 NewWkbook.SaveAs FileName:=FileName Else '##ファイルを新規保存 NewWkbook.SaveAs FileName:=FileName End If ' NewWkbook.Close savechanges:=False Application.DisplayAlerts = True End Sub
- ベストアンサー
- Visual Basic
- 保存の仕方
こんにちは、次のようなアドレスを入力するとそのソースを表示するプログラムを作ったのですがこれで表示されるソースに名前を付けて保存することってできますか？お願いします。 Private Sub Command1_Click() Dim strUrl As String Dim strBuf As String Command1.Enabled = False strUrl = InputBox("URLを入力して下さい.") If (Len(strUrl) = 0) Then Exit Sub End If Command1.Enabled = True strBuf = Inet1.OpenURL(strUrl) Form2.Show Form2.Text1.Text = strBuf End Sub Function Getsource() As String Dim strBuf As String Dim strUrl As String strBuf = Inet1.OpenURL(strUrl) 'ファイル内容を取得 Getsource = strBuf End Function
- ベストアンサー
- Visual Basic
- シートだけを保存したいのですが？
はじめましてマクロ初心者です。 検索しましたがわからなかったので、質問させていただきます。 保存をキャンセルすると新規ブックができてしまいます。 キャンセルした時に新規ブックを作りたくないのですが、教えてください。 Sub シート保存() Dim Answer3 Dim 既定ファイル名 As String Dim 保存ファイル名 As Variant Answer3 = MsgBox("本当に保存しますか？", vbYesNo) If Answer3 = vbYes Then Sheets("保存シート").Select Application.CutCopyMode = False Sheets("保存シート").Copy Else MsgBox ("キャンセルしました。") End If 既定ファイル名 = Range("V8") 保存ファイル名 = Application.GetSaveAsFilename(既定ファイル名) If 保存ファイル名 = False Then MsgBox "保存は中止されました。" Else ActiveWorkbook.SaveCopyAs 保存ファイル名 End If End Sub よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
お礼
またもや助けてもらいました。有難うございます。