こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

vba 西暦年表示の件

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

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

       記

  ○○年○月

投稿日時 - 2008-10-11 13:43:26

QNo.4393626

困ってます

質問者が選んだベストアンサー

'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

投稿日時 - 2008-10-11 16:43:40

お礼

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

投稿日時 - 2008-10-11 20:34:54

ANo.4

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(8)

ANo.8

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

投稿日時 - 2008-10-11 21:44:27

お礼

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

投稿日時 - 2008-10-12 10:08:55

ANo.7

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

投稿日時 - 2008-10-11 21:18:37

ANo.6

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

投稿日時 - 2008-10-11 21:02:46

ANo.5

ANo.1です。

#1に追加ですが。

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

投稿日時 - 2008-10-11 18:07:41

ANo.3

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

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

投稿日時 - 2008-10-11 15:49:21

ANo.2

ANo.1です。

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

投稿日時 - 2008-10-11 14:28:47

ANo.1

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
とかですかね。

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

投稿日時 - 2008-10-11 14:01:27

あなたにオススメの質問