VBAで時間を正規表現するパターン

質問

VBAで時間を正規表現するパターンを教えて下さい。

セル中の文字列に混在する
　時間の形式に統一性がありません。

考えられる形式は、以下のパターンです。

1:05:12
01:05:12

00:05:12
00：5：12
0：05：05
0：5：5
0:55:12

55:12 (mm:ss)
05:12 (mm:ss)
5:12 (mm:ss)
5：07 (mm:ss)
5：7 (mm:ss)

----------------------
ネットで探しても上記パターンを網羅するような
　コードを探しきれませんでした。

下記のコードでパターンがヒットしない場合あり苦慮しています。
（REGEXMATCHは、セルフ関数で
　　Google スプレッドシートの REGEXMATCH 関数と同等の機能です。）

For i = 1 To LastNo
If REGEXMATCH(Ws2.Cells(i, "A"), "\d{1,2}(:\d{1,2}){1,2}") Then
Ws1.Cells(i, "A") = Ws2.Cells(i, "A") '条件がTrueの場合
Else
Ws1.Cells(i, "A") = ""
End If
Next

回答No.5

kkkkkm · ベストアンサー

"\d{1,2}(:\d{1,2}|：\d{1,2}){1,2}"

にすれば「：」は半角全角どちらでも対応になり
mMatches.Item(0).Value
の値は元の半角全角が維持されます。

補足

kkkkkmさん、何度もアドバイスありがとうございます。

せっかくなので
　半角化のコードを付加してみました。
--------------
'処理対象を半角にコンバート(対策 / [:]が全角の場合)
'For i = 1 To LastNo
' Ws2.Cells(i, "B") = StrConv(Ws2.Cells(i, "A"), vbNarrow)
'Next
----------------
全角のカタカナが半角になるのが欠点なので
　（全角の漢字及び全角のひらがなは、全角のまま）

なので　パターン1
　mPattern = "\d{1,2}:\d{1,2}:\d{1,2}|\d{1,2}:\d{1,2}"
から　パターン2
　mPattern = "\d{1,2}(:\d{1,2}|：\d{1,2}){1,2}" '「：」が半角全角どちらでも対応
に変更してみましたが
　REGEXMATCH関数が機能しません。
　　　（パターン1では上手く機能してセルの書き出しができていますが
　　　　　パターン2では、セルの書き出しができていません。）

原因は何でしょうか　？

以下は、現在試用中のコードです。
（「処理対象を半角にコンバート(対策 / [:]が全角の場合)」の
　　コードは、コメントアウトして利用しなくしています。）

---------------------------------------
'Checkシート初期化
Ws1.Range("A1:B300").Clear

'処理対象を半角にコンバート(対策 / [:]が全角の場合)
'For i = 1 To LastNo
' Ws2.Cells(i, "B") = StrConv(Ws2.Cells(i, "A"), vbNarrow)
'Next

'MOTOシートに時間相当の記載が有る場合のみ別シート(Checkシート)に書き出す
'mPattern -> 時間相当/正規表現

'mPattern = "[0-9][0-9]:[0-5][0-9]:[0-5][0-9]|" & _
"[0-9]:[0-5][0-9]:[0-5][0-9]|" & _
"[0-9]:[0-9]:[0-5][0-9]|" & _
"[0-9]:[0-9]:[0-9]|" & _
"[0-9]:[0-5][0-9]|" & _
"[0-9]:[0-9]" '最も長いが分かりやすい

'mPattern = "\d{1,2}(:\d{1,2}){1,2}" 'S1299792さん紹介
'mPattern = "\d{1,2}:\d{1,2}:\d{1,2}|\d{1,2}:\d{1,2}"

mPattern = "\d{1,2}(:\d{1,2}|：\d{1,2}){1,2}" '「：」が半角全角どちらでも対応

Set Reg = CreateObject("VBScript.RegExp")
Reg.Pattern = mPattern

For i = 1 To LastNo

If REGEXMATCH(Ws2.Cells(i, "B"), mPattern) Then
Ws1.Cells(i, "A") = Ws2.Cells(i, "B") '条件がTrueの場合
Else
Ws1.Cells(i, "A") = ""
End If
Next

' Excel で Google スプレッドシートの REGEXMATCH 関数相当を使う
Public Function REGEXMATCH(str As String, pat As String) As Boolean
Dim Reg As Object
Set Reg = CreateObject("VBScript.RegExp")

With Reg
.Pattern = pat
.IgnoreCase = False
.Global = True
End With

REGEXMATCH = Reg.Test(str)

End Function

回答No.8

kkkkkm

> 　　変更前は
> 　　　　CHECKシートのA25が「空白」だったのが

いつのコードの話をしているのか分かりませんが
Trueの場合に

Ws1.Cells(i, "A") = Ws2.Cells(i, "A")

で空白になるとは思えません。

時間や日付だけのデータはシリアル値なのでそのまま代入すると数値で表示されます。
表示形式を適切なものにすれば時間として表示されます。

検索時のデータをvalueで渡すと生のままのデータが渡されますのでText(見た目)で渡しています。

お礼

>Ws1.Cells(i, "A") = Ws2.Cells(i, "A")

>で空白になるとは思えません。

私がセル操作中にクリアーにしてしまったのかもしれません。

考えられそうなDATAで処理しようとすると
　どうしても無理が出て、
　結局、最終的に結果を肉眼で確認して
　　必要ないゴミを削除する作業が多くなりそうです。

あまり欲張らず
　　コードは、ここで完成としたいと思います。

今回もお付き合い願い感謝します。

回答No.7

kkkkkm

> Ws1.Cells(n, "B").Text = Ws1.Cells(i, "A").Value

データの取得は.Textでできますが、セットは.Textではできませんから

Ws1.Cells(n, "B").Value = Ws1.Cells(i, "A").Text

に変更してみてください。

補足

>Ws1.Cells(n, "B").Value = Ws1.Cells(i, "A").Text

>に変更してみてください。

変更してみましたが、
　　上手く処理できていないようです。

（なぜだか？
　　変更前は
　　　　CHECKシートのA25が「空白」だったのが
　　　　今回は、「0.003645833」と表示されています。）

添付画像
https://imgur.com/P8KzwW6

回答No.6

kkkkkm

> 　mPattern = "\d{1,2}(:\d{1,2}|：\d{1,2}){1,2}" '「：」が半角全角どちらでも対応
> に変更してみましたが
> 　REGEXMATCH関数が機能しません。

質問にあるデータでは機能しました(一部カタカナも入れて)データの違いかもですが。

メインにある
Set Reg = CreateObject("VBScript.RegExp")
Reg.Pattern = mPattern
は不要ですね。

> 'For i = 1 To LastNo
> ' Ws2.Cells(i, "B") = StrConv(Ws2.Cells(i, "A"), vbNarrow)
> 'Next

こちらではなく検索するデータの方です。

REGEXMATCH = Reg.Test(StrConv(str, vbNarrow))

あと、単純な時間だけのデータ(02:15:10だけ)がある場合に条件はFalseになりますので、その可能性がある場合

If REGEXMATCH(Ws2.Cells(i, "B").Text, mPattern) Then

としておくといいと思います。

お礼

>質問にあるデータでは機能しました

すいません。
　kkkkkmさんから指摘されて、コードを見直して
　ミスが発覚したのでコードを修正しました。
　　（単純な時間だけのデータが有る場合のコードへ修正済み）

　下記が現在の（修正後の）コードです。

　　　（マクロを起動後の画像を添付します。）

https://imgur.com/cz1Uytn

全角のカタカナが半角になるのが欠点も無く
　これで完成と思われましたが
　なんと、
　　「A列を対象にB列に空白のセルをとばして（詰めて）転記する」
　コードを実施すると復活しました。
Ws1.Cells(n, "B")= Ws1.Cells(i, "A")　を以下のように変えましたが
　Ws1.Cells(n, "B").Text = Ws1.Cells(i, "A").Value

RangeクラスのTextプロパティを設定できません
（1004エラー）
が出ます。

最終的には、不必要なセルは肉眼で確認して
　削除することになるのでそれほど大変ではなさそうですが
　エラーが出なくなる方法はありますか　？

--------------------------------------------------------
Option Explicit

Sub Check_HHMMSS()

Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim LastNo As Single
Dim hhmmss As Object
Dim i As Single
Dim n As Single

Dim Reg As Object
Dim mMatches As Object
Dim mPattern As String

Set Ws1 = Worksheets("Check")
Set Ws2 = Worksheets("MOTO")

LastNo = Ws2.Cells(Rows.Count, "A").End(xlUp).Row

MsgBox "MOTOシートのA列にチェックする元になるLISTは存在しますか　？", 1 + 32, "Form_hhmmss"

If LastNo = 0 Then
MsgBox "元リストがA列に無いので処理を中止します"
Exit Sub
Else
'処理
End If

'Checkシート初期化
Ws1.Range("A1:B300").Clear

'MOTOシートに時間相当の記載が有る場合のみ別シート(Checkシート)に書き出す
'mPattern -> 時間相当/正規表現

mPattern = "\d{1,2}(:\d{1,2}|：\d{1,2}){1,2}" '「：」が半角全角どちらでも対応

For i = 1 To LastNo

If REGEXMATCH(Ws2.Cells(i, "A").Text, mPattern) Then
Ws1.Cells(i, "A") = Ws2.Cells(i, "A") '条件がTrueの場合
Else
Ws1.Cells(i, "A") = ""
End If
Next

'A列を対象にB列に空白のセルをとばして（詰めて）転記する
n = 1
For i = 1 To LastNo
If Ws1.Cells(i, "A") <> "" Then
Ws1.Cells(n, "B").Text = Ws1.Cells(i, "A").Value
n = n + 1
End If
Next

Set Ws1 = Nothing
Set Ws2 = Nothing

End Sub

' Excel で Google スプレッドシートの REGEXMATCH 関数相当を使う
Public Function REGEXMATCH(str As String, pat As String) As Boolean
Dim Reg As Object
Set Reg = CreateObject("VBScript.RegExp")

With Reg
.Pattern = pat
.IgnoreCase = False
.Global = True
End With

REGEXMATCH = Reg.Test(str)
End Function

回答No.4

kkkkkm

> 必要なら「：」の全角を半角に修正するコードを追加する予定です。

Set mMatches = Reg.Execute(StrConv(Cells(i, "A").Text, vbNarrow))

の

StrConv(Cells(i, "A").Text, vbNarrow)

で、セルの値を半角にして検査してますから「：」全角も検査結果は正しく出てると思います。

結果のmMatches.Item(0).Valueは半角にしたままです。

回答No.3

kkkkkm

"\d{1,2}(:\d{1,2}){1,2}"

は質問に書いてあったパターンです。
それで駄目だと記載があったので、駄目なんだなぁと思って全てのパターンを考えて

で、あとから試しにやってみたらできる感じだったので追加回答しました。

いまいちよくわかりませんが
\dは数値で0から9
{1,2}1文字から2文字
()はグループ
みたいですから、
「:」の前後1文字から2文字が数値で
()が繰り返し対応「:」2回対応、()で括るとそうなるのでしょう。

()の用法がよくわかりませんから、これを見るまでは
"\d{1,2}:\d{1,2}:\d{1,2}|\d{1,2}:\d{1,2}"
としたと思います。

補足

>"\d{1,2}(:\d{1,2}){1,2}"
>は質問に書いてあったパターンです。

失礼しました。

"\d{1,2}(:\d{1,2}){1,2}"　は、
　前回、「VBA - 区切り文字前後で抜き出す」で質問したとき
　その時は気づいたいなかったのですが
　kkkkkmさん以外に「S1299792」さんから回答を頂いていて
　解決後に回答が有った事に気が付いて
　便利な正規表現を紹介いただきました。

（S1299792さん、気が付かずに大変失礼しました。）

　ダメな場合が有ると言ったのは
　　　「：」が全角の場合、上手く処理できないようです。
　　　　(:が半角文字の場合はOK)

たまたま今回サンプルに使った中に
　　全角の「：」が無かったので上手く処理できました。

自分で質問に挙げておいて
　　すっかり　"\d{1,2}(:\d{1,2}){1,2}"　の存在を忘れていました。
---------------------------
kkkkkmさんでも難解な正規表現なので
初心者の私は、どこで区切って考えたら良いか？
　　　さっぱり分からないのが現状です。
----------------------------------
>\d{1,2}:\d{1,2}:\d{1,2}|\d{1,2}:\d{1,2}

　こちらも上手く処理できています。
（「：」が全角文字の場合を除く）

　必要なら「：」の全角を半角に修正するコードを追加する予定です。

回答No.2

kkkkkm

No1のmPatternを
mPattern = "\d{1,2}(:\d{1,2}){1,2}"
にしてもいけそうな感じですが

お礼

違うパターンを追加で紹介いただきありがとうございます。

>mPattern = "\d{1,2}(:\d{1,2}){1,2}"

こちらでも上手く処理できました。

\d{1,2}(:\d{1,2}){1,2} は、まるで私には呪文です。

これを読み解くとどのようになるのか？
　解説いただければ嬉しいです。

回答No.1

kkkkkm

強引に全てのパターンをORで繋ぐとか
(書式は最初標準にしておいて)
Sub Test()
Dim Reg As Object
Dim mMatches As Object
Dim mPattern As String

mPattern = "[0-9][0-9]:[0-5][0-9]:[0-5][0-9]|" & _
"[0-9]:[0-5][0-9]:[0-5][0-9]|" & _
"[0-9]:[0-9]:[0-5][0-9]|" & _
"[0-9]:[0-9]:[0-9]|" & _
"[0-9]:[0-5][0-9]|" & _
"[0-9]:[0-9]"
Set Reg = CreateObject("VBScript.RegExp")
Reg.Pattern = mPattern
For i = 1 To 50
Set mMatches = Reg.Execute(StrConv(Cells(i, "A").Text, vbNarrow))
If mMatches.Count > 0 Then
' If IsDate(mMatches.Item(0).Value) Then
Cells(i, "C").Value = mMatches.Item(0).Value
' End If
End If
Next
End Sub

お礼

kkkkkmさん、回答感謝します。

正規表現(mPattern)で上手く処理できました。

時間相当パターン（正規表現）は、
　使えると非常に便利なので利用したいのですが
　初心者の私にはなじみが少なく
　現状、非常に難易度が高い存在です。

　実際のサンプルを利用してコードを使いやすく改造中です。

　（過去、しばらくするとマクロの利用方法を忘れてしまう事が
　　頻発したのでコード中にコメントを増やしたり
　　マクロの進行に合わせてMSGBOXで進行の補助的メッセージを
　　表示するようにしています。）

　今回も無事に解決しました。