vba 西暦年表示の件

質問

お世話になります。
ＶＢＡで、西暦年表示を下２桁で表示させたく、
そして、月も含めて大文字に変換してエクセルシート
のシート名としたいのです。
下記の様なイメージです。
月表示は一桁の月は一桁表示です。

シートは当月と次月分と二つ作りたいのですが、
ご教示頂きたく宜しくお願い致します。

　　　　　　　記

　　○○年○月

回答No.4

diashun · ベストアンサー

'diashunです。
'昔作ったものに手を加えてみました。
'入力インターフェースにインプットボックスを使い、入力値のチェックもしています。以下をコピーしてください。

Option Explicit

Const gstrProhibited_char As String = ";/?*\[]"

'シート追加
Public Sub s_Create2Sheet()
Dim Sh As Object, ShName_1 As String, ShName_2 As String, i As Integer, InputName As String
Dim Wsh As Object, dtDate As Date, strDate As String, strMonth As String, InputName_Year1 As String, InputName_Month1 As String
Dim InputName_Year2 As String, InputName_Month2 As String
strDate = Mid(CStr(Year(Date)), 3, 2)
strMonth = CStr(Month(Date))

InputData:

InputName = Application.InputBox(Prompt:="年月(YYMM)を入力してください", _
Title:="新規シート年月", Default:=strDate)
'<何も入力せずOKの場合、処理を終わりにします。>
If InputName = "" Then Exit Sub
'<キャンセルの場合、処理を終わりにします。>
If InputName = "False" Then Exit Sub
' '<数字以外の入力があった場合、再入力します。>
If Not IsNumeric(InputName) Then
MsgBox ("入力できるのは数字だけです")
End If
'月数値チェック
If Not f_ChkName_Month(InputName) Then
GoTo InputData
End If
'禁止文字、文字長さチェック
If Not f_ChkName(InputName) Then
GoTo InputData
End If

'<全角変換します。>
' InputName = StrConv(InputName, vbNarrow)
InputName_Year1 = CStr(CInt(Mid(InputName, 1, 2))) & "年"
InputName_Month1 = CStr(CInt(Mid(InputName, 3, 2))) & "月"
If Mid(InputName, 3, 2) = "12" Then
InputName_Year2 = CStr(CInt(Mid(InputName, 1, 2)) + 1) & "年"
InputName_Month2 = CStr(CInt("01")) & "月"
Else
InputName_Year2 = Mid(InputName, 1, 2) & "年"
End If
InputName_Month2 = CStr(CInt(Mid(InputName, 3, 2)) + 1) & "月"

ShName_1 = InputName_Year1 & InputName_Month1
ShName_2 = InputName_Year2 & InputName_Month2

Set Sh = ThisWorkbook.Sheets 'シート数
Set Wsh = ThisWorkbook

'<同じワークシート名がないか確認します。>
For Each Sh In Wsh.Sheets
If Sh.Name = ShName_1 Then
MsgBox "この名前は既に使われています。別名で設定して下さい。"
Exit Sub
End If
Next
'<同じワークシート名がないか確認します。>
For Each Sh In Wsh.Sheets
If Sh.Name = ShName_2 Then
MsgBox "この名前は既に使われています。別名で設定して下さい。"
Exit Sub
End If
Next
'<新しいワークシート(1)を一番後ろに作成します。>
Worksheets.Add After:=Worksheets(Worksheets.Count)
'<追加されたワークシートに入力された名前を付けます。>
ActiveSheet.Name = ShName_1
'<新しいワークシート(2)を一番後ろに作成します。>
Worksheets.Add After:=Worksheets(Worksheets.Count)
'<追加されたワークシートに入力された名前を付けます。>
ActiveSheet.Name = ShName_2

End Sub

Private Function f_ChkName(Arg1 As String) As Boolean
Dim strProhibited_char As String
Dim i As Integer
f_ChkName = False

'文字長さチェック
If Len(Arg1) > 4 Then
MsgBox "シート名が長すぎます（4文字[YYMM]以内）。"
f_ChkName = False
Exit Function
End If

'禁止文字チェック
For i = 1 To 7
strProhibited_char = Mid(gstrProhibited_char, i, 1)
If InStr(1, Arg1, Mid(gstrProhibited_char, i, 1)) > 0 Then
MsgBox "シート名に使用できない文字「 " & strProhibited_char _
& " 」が含まれています。" & vbNewLine & "再入力してください。"
f_ChkName = False
Exit Function
End If
Next i

f_ChkName = True

End Function

Private Function f_ChkName_Month(Arg1 As String) As Boolean
Dim strMonth As String

f_ChkName_Month = False
strMonth = Mid(Arg1, 3, 2)
If strMonth < "01" Then
Exit Function
End If
If strMonth > "12" Then
Exit Function
End If

f_ChkName_Month = True
End Function

お礼

ありがとうございます。
ワークシートの追加の作成ですが、
同じワークシート名がなかったら、ワークシートをその名で
作成するとする場合はどの様な記述になりますでしょうか。
恐れ入りますが、再度ご教示頂きたく宜しくお願い申し上げます。

回答No.8

diashun

回答者：hige_082　さん。　
diashunです。なり変ってのご叱責、ありがとうございます 。
自分も初心者の頃は・・・などと、ま、ご寛容に。

お礼

大変失礼致しました。
ご無礼をお許し下さい。
ありがとうございました。

回答No.7

diashun

diashunです。
同じシート名がある場合は、インプットボックスを再表示して違う名前（この場合は年（YY）月（MM)）を入力しなおすようにするプロシージャにしていますので、既存のシート名（YY月M月）と競合することはないと思いますが・・・。「同じワークシート名がなかったら、ワークシートをその名で作成する場合はどの様な記述になりますでしょうか。」の意味が判断しかねますが・・・？？？。

回答No.6

hige_082

＞同じワークシート名がなかったら、ワークシートをその名で作成するとする場合はどの様な記述になりますでしょうか。
だから、ANo.4のdiashunさんの回答が、まさにそれですってば
テストぐらいしましょうよ、失礼ですよ

回答No.5

n-jun

ANo.1です。

＃１に追加ですが。

>シートは当月と次月分と二つ作りたいのですが、
新規のシートを２つ作りたいのでしょうか？
或いはどこかのシートをコピーして２つ作成し名前を変更したいのでしょうか？
若しくは既に存在しているシートの名前を変更したいとか？

回答No.3

pkh4989

こんにちは。
以下のようにして見てください。

Sub test()
　　Dim wNm1　　　　As String
　　Dim wNm2　　　　As String
　　'
　　wNm1 = StrConv(Format(Now, "yy年m月"), vbWide)
　　wNm2 = StrConv(Format(DateAdd("m", 1, Now), "yy年m月"), vbWide)
End Sub

回答No.2

n-jun

ANo.1です。

１月末日に実行すると期待通りに行かなかったのでスル～して下さい。

回答No.1

n-jun

Sub test()
Dim nam1 As String
Dim nam2 As String

nam1 = StrConv(Format(Date, "yy年m月"), vbWide)
nam2 = StrConv(Format(Date + 31, "yy年m月"), vbWide)

MsgBox nam1 & vbLf & nam2

End Sub
とかですかね。

ところで、１０月に実行すると１０月と１１月が出来ますが、１１月に実行すると１１月と１２月で
１１月がだぶってしまいますがいいのかな。