日付入力マクロ

質問

On Error Resume Next
Dim r As Range
Dim flg As Long
flg = 0
If Intersect(Target, Range("A4:A600,E4:E600,J4:J600")) Is Nothing Then Exit Sub 'A列のみを対象　最初につなげるところ
ActiveSheet.Unprotect
flg = 1

For Each r In Target
Dim a As Long
Dim b As String

With r
If Not .NumberFormatLocal = "ge.m.d" Or .Value = "" Then .NumberFormatLocal = "G/標準" 'セルの書式設定がH00.m.d形式だったら標準に戻す
'セルが　数字　　　　且　　　　　　整数　　　　且　　101以上　　且　　　　991231以下　の場合
If IsNumeric(.Value) And Int(.Value) = .Value And .Value >= 19010101 And .Value <= 20991231 Then
b = Left(.Value, 4) & "/" & Mid(.Value, 5, 2) & "/" & Right(.Value, 2)

If IsDate(b) Then 'もしbがDateの形なら
.Value = CDate(b) 'データ型を日付にする
'ここにつなげる。　変数はtmpからbに直す
.NumberFormatLocal = "ggg" & _
IIf(Format(b, "e") > 9, "e年", "_0e年") & _
IIf(Month(b) > 9, "m月", "_1m月") & _
IIf(Day(b) > 9, "d日", "_1d日")

ActiveSheet.Protect
End If
End If
End With
Next

End Sub

上記のマクロで20090731と入力すると平成21年7月31日と表示されます。
210731を入力して平成21年7月31日と表示されるようにすることは可能ですか？

回答No.1

kmetu · ベストアンサー

If Not .NumberFormatLocal = "ge.m.d" Or .Value = "" Then .NumberFormatLocal = "G/標準" 'セルの書式設定がH00.m.d形式だったら標準に戻す
'セルが　数字　　　　且　　　　　　整数　　　　且　　101以上　　且　　　　991231以下　の場合
If IsNumeric(.Value) And Int(.Value) = .Value And .Value >= 101 And .Value <= 1111231 Then
b = Str(Val(Left(.Value, 2)) + 1988) & "/" & Mid(.Value, 3, 2) & "/" & Right(.Value, 2)

にしたらいかがでしょう。

お礼

完璧にできました。ありがとうございました！！！

回答No.3

Wendy02

こんばんは。

お書きになったコードは、ご自身が書いたものですか？出だしの部分を省略されたら、質問の要件としては不十分です。Target と書いたのなら、イベント・ドリブン型だとは思うのでいれましたが、省略はできません。それと、Protect をマクロで入れたら、二度目のイベントは動きません。数字が、6文字か8文字で書式を換えることにしました。ほとんど、元のコードは参考にはしませんでした。

セルの書式設定を戻す部分は、今のところ安易に戻すというように決められませんでした。不具合があれば別ですが、本当に必要かどうか、見た感じでは分かりません。日付型になっていれば、そのまま上書きすればよいと思うのです。そうすれば、その2桁かどうかの内容によって、変更されます。

また、 Application.EnableEvents が必要なのは、現時点では不明というか、貼り付けするときぐらいだけだと思います。

'シートモジュール
'-------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim buf As Variant
　 If Intersect(Target, Range("A4:A600")) Is Nothing Then Exit Sub 'A列のみを対象

　 Application.EnableEvents = False
　 For Each c In Target
　　 If IsNumeric(c.Text) Then
　　　　If Len(c.Text) = 8 Then
　　　　　buf = Format(c.Value, "00/00/00")
　　　　ElseIf Len(c.Text) = 6 Then
　　　　　buf = "H" & Format$(c.Value, "00/00/00")　'平成のみ
　　　　End If
　　　　If IsDate(buf) Then
　　　　　buf = CDate(buf)
　　　　　c.Value = buf
　　　　　c.NumberFormatLocal = DateFormatSpaces(buf)
　　　　End If
　　 ElseIf IsDate(c.Value) Then
　　　　c.NumberFormatLocal = DateFormatSpaces(c.Value)
　　 End If
　 Next c

　Application.EnableEvents = True
End Sub

Private Function DateFormatSpaces(ByVal vDate As Variant) As String
　　Dim iY As Integer, iM As Integer, iD As Integer
　　Const GENGO As String = "ggg"
　　If IsDate(vDate) = False Then Exit Function
　　iY = 2 - Len(Format(vDate, "e"))
　　iM = 2 - Len(Month(vDate))
　　iD = 2 - Len(Day(vDate))
　　DateFormatSpaces = GENGO & Space(iY) & "e年" & Space(iM) & "m月" & Space(iD) & "d日"
End Function

補足

マクロ初心者です。そのコードは自分で書いたものではありません。
If IsNumeric(.Value) And Int(.Value) = .Value And .Value >= 101 And .Value <= 1111231 Then
b = Str(Val(Left(.Value, 2)) + 1988) & "/" & Mid(.Value, 3, 2) & "/" & Right(.Value, 2)
にすることで、できました。ありがとうございました。

回答No.2

kmetu

あと全体を

Application.EnableEvents = False
コード
Application.EnableEvents = True

としたほうがいいと思います