VBAを使って名前をつけて保存をしたい(2)

質問

Sub 名前を付けて保存()
Dim wSeq As String
Dim wStr As String
Dim Flnm As String
Dim wFlnm As String
'
Sheets("データー").Select
Range("C3").Select
ActiveWorkbook.Save

Flnm = "\\Jooo\センタ\AA\CC" & Format(Date, "【mmdd】") & ".xls"

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 & ".xls"
Else
'存在しない時、保存
ActiveWorkbook.SaveAs Filename:=Flnm
ExitFlg = True
End If
Loop
End Sub

先日回答者の方から上記コードを教えてもらい助かっているんですが、少し不都合でてきまして、上記を実行すると最初にCC【1022】という名前でフォルダに保存され、二回目に実行するとCC【1022】(1)という名前で同じフォルダに保存され、三回目に実行するとCC【1022】(2)というように連番で同じフォルダに保存されるんですが、一番最初に保存されたCC【1022】を削除して(どんどんBookが溜まっていくのを防ぐ為)四回目に実行すると【1022】(3)ではなく最初のCC【1022】の名前で保存されてしまいます。【1022】を削除してもCC【1022】(3)で保存されるようにするには、コードをどの様にかえたらいいでしょうか?

回答No.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

お礼

またもや助けてもらいました。有難うございます。

回答No.4

fujillin

#3です
（少しだけ訂正を）
（）内の文字を取り出す部分は
　wStr = Replace(Replace(wFlnm, Flnm & "(", ""), ").xls", "")
のようにした方が、少し正確な処理になりそうですね。
（正規表現が使えれば簡単なんですが・・・）

数字のみの文字列であることの簡単なチェックを探しましたが、こちらも正規表現が使えないみたいなので、ループで1文字ずつチェックする方法しか思いつきません。
そのへんのチェックの追加は、適当にアレンジしてください。

回答No.3

fujillin

windowsの場合はDir関数に*をワイルドカードとして使用できますので、「CC　【1022】　*.xls」を検索して、最大番号+1を新ファイル名とすればよいでしょう。
Macの場合は*が使用できないので、フォルダ内のファイルに対して、ファイル名を含めて比較してゆくことで可能です。

（）内の数字を比較する時に文字で比較すると、8＞10というようなことが起りますので、必ず数字で比較する必要があります。

＜Winの場合の参考例を＞
（下の例では、少々手を抜いて、通し番号はIsNumeric()のチェックしかしていませんので、必ずしも整数文字列だけが対象になるようにはなっていません。）

Sub test()
Dim wSeq As Integer, wSstrt As Integer, wSend As Integer
Dim Flnm As String, wFlnm As String, wStr As String
Const dPath = "\\Jooo\センタ\AA\"

Flnm = "CC" & Format(Date, " 【mmdd】 ")
ActiveWorkbook.Save

wSeq = -1
wFlnm = Dir(dPath & Flnm & "*.xls")
Do While wFlnm <> ""
　wSstrt = InStr(wFlnm, "(")
　wSend = InStr(wFlnm, ")")
　If (0 < wSstrt) And (wSstrt < wSend) Then
　　wStr = Mid(wFlnm, wSstrt + 1, wSend - wSstrt - 1)
　　If IsNumeric(wStr) Then
　　　If wSeq < Val(wStr) Then wSeq = Val(wStr)
　　End If
　Else
　　If (wFlnm = Flnm & ".xls") And (wSeq < 0) Then wSeq = 0
　End If
　wFlnm = Dir
Loop
If wSeq < 0 Then wStr = "" Else wStr = "(" & wSeq + 1 & ")"

wFlnm = Flnm & wrtr & ".xls"
ActiveWorkbook.SaveAs Filename:=dPath & wFlnm
MsgBox ("ファイル名を" & wFlnm & "として保存しました。")
End Sub

お礼

検討してみます。ありがとうございます。

回答No.1

n-jun

”CC【1022】”で始まるファイルを順に見ていき、"()"で挟まれた数字がカウンタと比べて小さい或いは同じ場合は、
カウンタを＋１していく。
カウンタが数字を超えたらそのカウンタをファイル名に使用する。

と言った感じではないでしょうか？（って憶測ですけど）

補足

多分そうです。ただ上記のコードをどの様に書き換えたらいいのかが、ちょっとわからないので(素人なもんで)教えて欲しいのですが・・・