VBAで年月日の型変換するプログラム

質問

現在ＶＢＡで年月日の型変換するプログラムを作成しています。
やりたい内容はシート１の『A1』セルに例えば
『平成１８年　４月　１日（　土　曜日）　午前９時００分頃から
　平成１８年　４月　２日（　日　曜日）　午後３時００分の間』
と入力されているのでそれをシート２では
『18. 4. 1. 9:00(改行)
～（改行）
18. 4. 2.15:00』
という風に型変換して入力したいです。ボタンを押すとコピーするようになっているのですが、現在、

Sheet2.Cells(rng.Row, 1).Value = Sheet1.Range("A1").Value

という風にプログラムを組んでいます。（A1を　判別した行の１列目に挿入といった内容）
これだとそのままの状態をコピーなので、なんとか型返還させたいです。助けてください。
ちなみに午前・午後というものがあるのでそれは24時表記にしたいです。
それと型変換では半角にしたいです。
例外で
『平成１８年　４月　１日（　土　曜日）　午前９時００分』のみの時もあるのでそのときは
『18. 4. 1. 9:00』だけ入力できればいいのですが・・・
なんとか力を貸していただけないでしょうか？
本当にお願いします。

回答No.3

BLUEPIXY · ベストアンサー

>スペースが多すぎたり
スペースとかは、パターンに吸収させることができるかもしれません。
または、前処理としてスペースをReplace 等を使って取り除いておくといいかもしれません。

＞型があわなかったり
Set matches = regEx.Execute(dateTxt)
の後で
If Matches.Count = 0 Then
MsgBox "パターンに合致しません"
Else
' マッチした時の処理
End If
のように Matches.Count の値が ０ の時にはパターンに合致しなかったことが判別できます。

回答No.2

BLUEPIXY

#1>右側をどのように変更したらよいのでしょうか？
そのまま使うなら、
Sheet2.Cells(rng.Row, 1).Value = convertDate(Sheet1.Range("A1"))
のようにすればいいです。

なんだったら、
r As Range　を dateStr As String に変えて
r.value を dateStr に変更すれば
Sheet2.Cells(rng.Row, 1).Value = convertDate(Sheet1.Range("A1").Value)
のようにできます。
お好みでどうぞ。

補足

返事が遅れてしまいすいません。本当に助かりました。！！すごくうれしいです。
一つ質問してもよろしいでしょうか？
ちゃんと型変換もでき、私のやりたかったことができました。！
それでエラー処理として、まったく違う文字をうってしまったり
スペースが多すぎたり、型があわなかったりすると、エラーになってしまいます。
このときにエラーメッセージとして
『スペースが多いか、型が違います』みたいなエラーメッセージを出してやり直しを促すような処理をほどこしたいのですが、
どのプログラムの部分をどう追加すればよいのかわからず
悪戦苦闘しております。どうかお力をかしていただけないでしょうか。
お願いします。困っていまして・・

回答No.1

BLUEPIXY

ユーザー定義関数として作成してみました。
標準モジュールに置いて下さい
適当なセルで
=convertDate(Sheet1!A1)
のように使います。
セルの書式設定の配置で折り返して全体を表示するにチェックを付けて置いて下さい。（分までが入るセル幅にしておきます）
----------------------------------------------------------------
Public Function convertDate(r As Range) As String
Dim dateTxt As String
Dim regEx, matches, match
Dim startDate As String, endDate As String

dateTxt = StrConv(r.Value, vbNarrow) '数値を半角に
Set regEx = CreateObject("VBScript.RegExp")

regEx.Global = True
regEx.Pattern = "(\d+).+?(\d+).+?(\d+).+?(午前|午後)(\d+).+?(\d+)"
Set matches = regEx.Execute(dateTxt)
Set match = matches(0)
With match
startDate = .SubMatches(0) & ". " & .SubMatches(1) & ". " & .SubMatches(2) & ". " & _
.SubMatches(4) + IIf(.SubMatches(3) = "午後", 12, 0) & ":" & .SubMatches(5)
End With
If matches.Count > 1 Then
Set match = matches(1)
With match
endDate = .SubMatches(0) & ". " & .SubMatches(1) & ". " & .SubMatches(2) & ". " & _
.SubMatches(4) + IIf(.SubMatches(3) = "午後", 12, 0) & ":" & .SubMatches(5)
End With
Else
endDate = ""
End If
If endDate = "" Then
dateTxt = startDate
Else
dateTxt = startDate & vbLf & "～" & vbLf & endDate
End If
convertDate = dateTxt
End Function

補足

私の作成した
Sheet2.Cells(rng.Row, 1).Value = Sheet1.Range("A1").Value
の右側を変えるのと、他にBLUEPIXYさんが考えてくださったプログラムをまるまる今のプログラムに当てはめることでやってみたいと思いますが、セルにいれるのではなく＝の右側をどのように変更したらよいのでしょうか？
Sheet2.Cells(rng.Row, 1).Value =convertDate(Sheet1!A1)
という使い方でいいのでしょうか？　教えてください。
本当に困っていてＢＬＵＥさんのお力をかりたいです。