見積書のナンバリングで悩んでます。

今の会社は見積書の番号を
(1)作成日付
(2)その日の何番目に作成された物か（ハイフン前・2桁）
(3)同じ宛先に違う見積を何枚か出す時に分ける為の番号（ハイフン後・2桁）
としています。
（例）8/1の1番目に作った見積（1枚のみ）⇒H20080101-01。
原本ファイルを“名前をつけて保存”にしてるのですが、(2)が重複してしまう事が多いので自動的にナンバリングされるようにしたいのです。
日付が自動的に入るマクロもナンバリングがされていくマクロも過去の投稿を見てわかるのですが、組み合わせ（？）になると全くどうしていいのか・・。
もしくは“左から何番目まで文字が被ると保存ができない”的な便利な機能があったらどなたかご教授願えませんでしょうか。
よろしくお願い致します。

No.2 ベストアンサー 回答者： chibita_papa 回答日時： 2008/08/01 19:40

Ｎｏ1です。

失礼しました。
大ボケな回答でした。
再度回答します。

まず、空のワークシートを作成
"Z:\請求書No.xls"

A1 <= 作成日付
B1 <= 何番目に作成された物か
A2以下　A列　取引先名
B2以下　B列　同じ宛先に違う見積を何枚か出す時に分ける為の番号
です。

以下、マクロをステップで確認してみてください。

Sub test()
Debug.Print "佐藤商会", GetSeikyuNo("佐藤商会")
Debug.Print "鈴木商事", GetSeikyuNo("鈴木商事")
Debug.Print "佐藤商会", GetSeikyuNo("佐藤商会")
Debug.Print "佐藤商会", GetSeikyuNo("佐藤商会")
Debug.Print "鈴木商事", GetSeikyuNo("鈴木商事")
Debug.Print "山田興産", GetSeikyuNo("山田興産")
End Sub

Function GetSeikyuNo(ByVal TokName As String) As String

Application.ScreenUpdating = False

Dim SeikyuNo As String

Workbooks.Open Filename:="Z:\請求書No.xls"

Dim ws As Worksheet

Set ws = ActiveWorkbook.Sheets("Sheet1")

If ws.Range("A1") <> Format$(Now, "geemmdd") Then
ws.Range("A2:B65536").Clear
Range("B1") = 1
ws.Range("A1") = Format$(Now, "geemmdd")
Else
Range("B1") = Range("B1") + 1
End If

Dim r As Integer

For r = 2 To ws.Range("A65536").End(xlUp).Row

If TokName = Cells(r, 1) Then

ws.Cells(r, 2) = ws.Cells(r, 2) + 1

SeikyuNo = ws.Range("A1") & Format$(ws.Range("B1"), "00") & "-" & Format$(ws.Cells(r, 2), "00")

Exit For

End If

Next r

If SeikyuNo = "" Then

r = ws.Range("A65536").End(xlUp).Offset(1, 0).Row

ws.Cells(r, 1) = TokName
ws.Cells(r, 2) = 1

SeikyuNo = ws.Range("A1") & Format$(ws.Range("B1"), "00") & "-" & Format$(ws.Cells(r, 2), "00")

End If

set ws = nothing
ActiveWorkbook.Save
ActiveWindow.Close

GetSeikyuNo = SeikyuNo

Application.ScreenUpdating = True

End Function

この回答へのお礼

ご教授ありがとうございます。あまりマクロ等得意ではないので時間がかかってしまいまいたが、おかげ様でできました！！
お礼が遅くなり申し訳ございません。
ご多忙中本当にありがとうございました。

お礼日時：2008/08/06 09:31

No.3 回答者： hallo-2007 回答日時： 2008/08/02 10:29

>(3)同じ宛先に違う見積を何枚か出す時に分ける為の番号（ハイフン後・2桁）

同じ日付に同じ宛先に複数の見積書を出す場合
という事で

一応　関数案ですが
　A　　　B　　　C　　D
日付　　宛先
8月1日　A社
8月1日　A社
8月1日　A社
8月1日　B社
8月2日　B社
8月1日　B社
8月2日　C社
・・・とあるとして
C列に作業列で　=A2&B2　下へたっぷりとコピィしておく
D列に　
=IF(A2="","",TEXT(A2,"geemmdd")&TEXT(COUNTIF(A2:A$2,A2),"00")&"-"&TEXT(COUNTIF(C2:C$2,C2),"00"))
で下へたっぷりとコピィしておく。
C列は非表示にでもしておくとか。
D列に希望の番号が出ませんでしょうか・

この回答へのお礼

ありがとうございます。お礼が遅くなり申し訳ございません。
この方法でもできました！ご多忙中ありがとうございました。

お礼日時：2008/08/06 09:29

No.1 回答者： chibita_papa 回答日時： 2008/08/01 18:31

請求書ナンバーをワークシート外に保存することにして、

例えば、"z:\Seikyusyo.No"

Sub aaa()

Dim No As String
Dim NewNo As String
Dim FileNum As Integer

FileNum = FreeFile

Open "z:\Seikyusyo.No" For Input As FileNum
Line Input #FileNum, No
Close #FileNum

If Left(No, 9) <> "H" & Format$(Now, "yyyymmdd") Then
'頭の9桁が違うので昨日以前のもの　初期化する
NewNo = "H" & Format$(Now, "yyyymmdd") & "-01"
Else
No = Right(No, 2)
NewNo = "H" & Format$(Now, "yyyymmdd") & "-" & Format$(Val(No) + 1, "00")
End If

Open "z:\Seikyusyo.No" For Output As FileNum
Print #FileNum, NewNo
Close #FileNum

End Sub

> もしくは“左から何番目まで文字が被ると保存ができない”的な便利な機能
ちょっと意味が分かりません