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)というふうに)どの様に上記を変更したらいいでしょうか?

回答No.1

pkh4989 · ベストアンサー

日付を追加しました。
「連番.dat」ファイルを削除して最初の状態で試してみてください。

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
　　Dim xDate　 As String
　　'
　　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
　　'
　　xDate = Format(Date, "mmdd")

　　wSeq = 0
　　wSeq = Get_Seq(xDate, 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(xDate, wDir, wSeq)
End Sub
'連番取得
Function Get_Seq(xDate As String, wDir As String, ER As Boolean) As Integer
　　Dim n As Long
　　Dim wDate As String
　　Dim Seq As Integer
　　'
　　ER = False
　　Seq = 0
　　On Error GoTo ExitER
　　n = FreeFile
　　Open wDir & "連番.dat" For Input As #n
　　Input #n, wDate, Seq
　　Close #n
　　If wDate = xDate Then
　　　　Get_Seq = Seq + 1
　　Else
　　　　Get_Seq = 1
　　End If
　　Exit Function
ExitER:
　　ER = True
　　Seq = 1
　　On Error GoTo 0
End Function
'連番保存
Function Put_Seq(xDate As String, wDir As String, wSeq As String)
　　Dim n As Long
　　n = FreeFile
　　Open wDir & "連番.dat" For Output As #n
　　Print #n, xDate & "," & wSeq
　　Close #n
End Function

お礼

今日やってみて上手くいきました。何度もありがとうごさいます。