ｗｏｒｄ文書の途中の文字を判別して消すＶＢＡ

質問

excelのマクロは少しかじっていますが、word　vbaは全くの初心者です。宜しくお願いします。

　例えば、下のように、似かよった文面が複数行ある文書で

　[8:50:31] qqe-CF: The building where Q-ty’s friend lives is very old.
　[8:50:53] qqe-CF: The town where my father grew up is small.
　[8:51:40 | 8:52:14] qqe-CF: That is the school where Q-rex teaches.
　[8:52:44] qqe-CF: That is the room where I keep my books.
　[8:53:59 | 8:54:14] qqe-CF: This is a picture of the place where we are going for our holidays.
　[8:54:33] qqe-CF: This is the place where I fell off my bike.
　[8:54:52] qqe-CF: That is the place where we stayed for our honeymoon.
↑ここの左端から半角10文字目から始まる、半角10文字で、それが数字の場合（3行目の「 8:52:14」など）のみを、指定した複数行に渡り、数字か文字かを判別しながら自動で繰り返し削除するＶＢＡマクロのプログラムを教えて下さい。

　質問内容のまとめ
　１．各行の、左端から半角10文字目から始まる半角10文字を削除対象とする。
　２．数字のみを削除対象とし、文字はスルーする。
　３．操作範囲行を指定できるようにする。１行から１000行の範囲で。

　実際には、１０００行以上の文書です。よろしくお願いします

回答No.3

eden3616 · ベストアンサー

失礼しました。
以下のコードは「文字か、数字かで判断する場合」で置き換えたものになります。
補足の問題点を修正いたしましたのでご確認お願いします。

結果の問題点
１．7行目の文字を削除してしまった。
　→　削除処理判定flagが正常に行われていなかったため修正しました。

２．9行目から最終行の間の削除処理が行われていない。
　→　"["から8文字シフトした後、行末までの文字数が10文字無い場合に
　　　次の行を跨ぎ処理をしていましたので修正しました。
　→　末尾まで10文字確保できない場合『[8:31:25 | 8:31:2』などはスキップされます。

気になること・・・
補足にてご提示の元の文面には以下の統一性がありません。
「を編集しました」と「編集しました」や「]」の有無など行によって結果が異なります。

現在の処理は"["を検索した位置より8文字右へシフトしたところから10文字を抜出し
抜き出した文字が特定文字「数値, ,:,/」であれば削除、それ以外ではればそのまま。
8文字シフトした位置から末尾までで10文字取得できなければ次の"["を検索・・・
としております。

■VBAコード

Sub sample()
'変数を宣言
Dim lmoji As String, lVal As String, cVal As String
Dim aa As String, pp As String, a As String, p As String
Dim flag As Boolean
Dim i As Integer

　　'検索文字を指定
　　lmoji = "["
　　'カーソルを先頭へ
　　Selection.HomeKey Unit:=wdStory
　　Application.ScreenUpdating = False
　　'メイン処理
　　Do
　　　　'検索条件を設定
　　　　With Selection.Find
　　　　　　.Forward = True
　　　　　　.ClearFormatting
　　　　　　.MatchWholeWord = True
　　　　　　.MatchCase = False
　　　　　　.Wrap = wdFindContinue
　　　　　　'lmojiを検索
　　　　　　If .Execute(FindText:=lmoji, Forward:=True, Format:=True) = True Then
　　　　　　　　'行、頁位置を取得
　　　　　　　　aa = Selection.Information(wdFirstCharacterLineNumber)
　　　　　　　　pp = Selection.Information(wdActiveEndPageNumber)
　　　　　　　　'末尾までの対象文字を10文字分取得可能か判定
　　　　　　　　Selection.EndKey Unit:=wdLine, Extend:=wdExtend
　　　　　　　　If Len(Selection) - 9 < 10 Then
　　　　　　　　　　flag = False
　　　　　　　　Else
　　　　　　　　　　'文字列の取得
　　　　　　　　　　Selection.MoveLeft Unit:=wdCharacter, Count:=1
　　　　　　　　　　Selection.MoveRight Unit:=wdCharacter, Count:=8
　　　　　　　　　　Selection.MoveRight Unit:=wdCharacter, Count:=10, Extend:=wdExtend
　　　　　　　　　　lVal = Selection
　　　　　　　　　　flag = True
　　　　　　　　End If
　　　　　　End If
　　　　　　'開始位置ならループ終了
　　　　　　If a = aa And p = pp Then Exit Do
　　　　　　'末尾まで10文字確保できない場合は処理をスキップ
　　　　　　If flag Then
　　　　　　　　'文字を取得して判定
　　　　　　　　For i = 1 To Len(lVal)
　　　　　　　　　　cVal = Mid(lVal, i, 1)
　　　　　　　　　　If IsNumeric(cVal) Then
　　　　　　　　　　　　'数値の場合
　　　　　　　　　　　　flag = True
　　　　　　　　　　Else
　　　　　　　　　　　　'文字の場合
　　　　　　　　　　　　If cVal = ":" Or cVal = "|" Or cVal = " " Then
　　　　　　　　　　　　　　flag = True
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　flag = False
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　　　If flag = False Then Exit For
　　　　　　　　Next i
　　　　　　　　'対象文字の削除
　　　　　　　　If flag Then
　　　　　　　　　　Selection.Delete Unit:=wdCharacter
　　　　　　　　　　flag = False
　　　　　　　　End If
　　　　　　End If
　　　　　　'初期位置を記録
　　　　　　If a = "" Then a = aa: p = pp
　　　　　　'検索位置をシフト
　　　　　　.Parent.Move Count:=1
　　　　End With
　　　　DoEvents
　　Loop
　　Application.ScreenUpdating = True
　　Selection.Find.ClearFormatting
End Sub

お礼

早速の修正版をありがとうございます。
使ってみました。完璧です。助かります～感謝申し上げます。

ご呈示頂いた、ＶＢＡは、私にはまだ解読できませんが、勉強して理解していきたいと思います。

本当にありがとうございました。m(_ _)m

回答No.2

eden3616

私もVBAはエクセル程度しか扱っていないので、
Word VBAは素人ですが作成してみました。

カーソル位置をMoveRightやMoveDownで確実に
各先頭行からn文字と指定することも出来ますが
複数行にわたる文面に対する処理を不要にする事と、
処理速度を考慮して"["を検索した位置を基準としています。

■判定方法について
[8:51:40 | 8:52:14] qqe-CF: That is the school where Q-rex teaches.
コード簡略化のため、Likeにより上記の場合の判定部分『 | 8:52:14』が『 |*:*:*』に一致するかで判定しています。
ご質問内容のように文字か、数字かで判断する場合は以下の箇所を追加・差替えてください。

'変数を宣言【同コメント内の最後に追加】
dim i As Integer

'文字列の取得 【同コメント内を全差替え】
Selection.MoveRight Unit:=wdCharacter, Count:=8
Selection.MoveRight Unit:=wdCharacter, Count:=10, Extend:=wdExtend
lVal = Selection

'文字を取得して判定 【同コメント内を全差替え】
For i = 1 To Len(lVal)
　　cVal = Mid(lVal, i, 1)
　　If VarType(cVal) = vbDouble Then
　　　　'数値の場合
　　　　flag = True
　　Else
　　　　'文字の場合
　　　　If cVal = ":" Or cVal = "|" Or cVal = " " Then flag = True
　　End If
　　If flag = False Then Exit For
Next i

'対象文字の削除【同コメント内を全差替え】
If flag Then
　　Selection.Delete Unit:=wdCharacter
　　flag = False
End If

■VBAコード

Sub sample()
'変数を宣言
Dim lmoji As String, lVal As String, cVal As String
Dim aa As String, pp As String, a As String, p As String
Dim flag As Boolean

　　'検索文字を指定
　　lmoji = "["
　　'カーソルを先頭へ
　　Selection.HomeKey Unit:=wdStory
　　Application.ScreenUpdating = False
　　'メイン処理
　　Do
　　　　'検索条件を設定
　　　　With Selection.Find
　　　　　　.Forward = True
　　　　　　.ClearFormatting
　　　　　　.MatchWholeWord = True
　　　　　　.MatchCase = False
　　　　　　.Wrap = wdFindContinue
　　　　　　'lmojiを検索
　　　　　　If .Execute(FindText:=lmoji, Forward:=True, Format:=True) = True Then
　　　　　　　　'行、頁位置を取得
　　　　　　　　aa = Selection.Information(wdFirstCharacterLineNumber)
　　　　　　　　pp = Selection.Information(wdActiveEndPageNumber)
　　　　　　　　'文字列の取得
　　　　　　　　Selection.EndKey Unit:=wdLine, Extend:=wdExtend
　　　　　　　　lVal = Selection.Text
　　　　　　End If
　　　　　　'開始位置ならループ終了
　　　　　　If a = aa And p = pp Then Exit Do
　　　　　　'文字を取得して判定
　　　　　　If Mid(lVal, 9, 10) Like " |*:*:*" Then flag = True
　　　　　　'対象文字の削除
　　　　　　If flag Then
　　　　　　　　Selection = Replace(lVal, Mid(lVal, 9, 10), "")
　　　　　　　　flag = False
　　　　　　End If
　　　　　　'初期位置を記録
　　　　　　If a = "" Then a = aa: p = pp
　　　　　　'検索位置をシフト
　　　　　　.Parent.Move Count:=2
　　　　End With
　　　　DoEvents
　　Loop
　　Application.ScreenUpdating = True
　　Selection.Find.ClearFormatting
End Sub

お礼

eden3616さん
ご丁寧に回答いただきましてありがとうございます。感謝申し上げます。

早速、ご呈示のＶＢＡコードを「文字か、数字かで判断する場合」で、該当箇所を追加・差替えてテストしてみました。結果が以下の通りです。
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
処理対象文の＜処理前＞
[8:31:32 | 8:31:59を編集しました] qqe-CF: What do you think . . .
[8:31:25 | 8:31:27を編集しました] qqe-CF: I recommend you . .
[8:31:25 | 8:31:27を編集しました] qqe-CF: I recommend you . .

[8:31:25を編集しました] qqe-CF: I recommend you . .
[8:31:26 | 8:31:59を編集しました] qqe-CF: What do you think . . .
[8:42:27 qqe-CF: What do you think of the book?
[8:31:28 | 8:31:27を編集しました] qqe-CF: I recommend you . .
[8:31:32を編集しました] qqe-CF: What do you think . . .
[8:42:33qqe-CF: What do you think of the book?
[8:33:33を編集しました]
[8:31:34 | 8:31:27を編集しました] qqe-CF: I recommend you . .
[8:31:34編集しました] qqe-CF: What do you think . . .
[8:42:34qqe-CF: What do you think of the book?
[8:33:35編集しました]
[8:31:16 | 8:31:27を編集しました] qqe-CF: I recommend you . .
[8:31:32を編集しました] qqe-CF: What do you think . . .
[8:33:17 | 8:33:51を編集しました]
＜処理後＞　　　↓↓↓
[8:31:32を編集しました] qqe-CF: What do you think . . .
[8:31:25を編集しました] qqe-CF: I recommend you . .
[8:31:25を編集しました] qqe-CF: I recommend you . .

[8:31:25を編集しました] qqe-CF: I recommend you . .
[8:31:26を編集しました] qqe-CF: What do you think . . .
[8:42:27hat do you think of the book?
[8:31:28を編集しました] qqe-CF: I recommend you . .
[8:31:32を編集しました] qqe-CF: What do you think . . .
[8:42:33qqe-CF: What do you think of the book?
[8:33:33を編集しました]
[8:31:34 | 8:31:27を編集しました] qqe-CF: I recommend you . .
[8:31:34編集しました] qqe-CF: What do you think . . .
[8:42:34qqe-CF: What do you think of the book?
[8:33:35編集しました]
[8:31:16 | 8:31:27を編集しました] qqe-CF: I recommend you . .
[8:31:32を編集しました] qqe-CF: What do you think . . .
[8:33:17を編集しました]
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
※4行目に空白行が入っています。
1行目～8行目までは、対象範囲の10文字数だけ削除されていますが７行目だけは文字なのに10文字が削除されています。そこから以降の行は処理せずに最終行に飛んで削除処理して終わっています。

結果の問題点
１．7行目の文字を削除してしまった。
２．9行目から最終行の間の削除処理が行われていない。
以上の問題点が解決できればと願っております。お手数を掛けますが、また、お願いできればとおもいます。
宜しくお願いします。

回答No.1

eden3616

VBAでの回答ではありませんが・・・
もし2個目の時間部分を削除したいだけなら正規表現置換でいいのでは？

http://utils.ipentec.com/WebTextUtility/ReplaceText/
上記サイトの入力に対象の文章をコピーし、

置換パターン：
(\[[\d\:]+) \| [\d\:\] ]+(\w.+)

置換文字列：
$1] $2

を入力して置換実行をクリックしてください。

お礼

ご親切に回答していただきまして、本当にありがとうございました。感謝申し上げます。m(_ _)m

補足

回答ありがとうございます。折角の回答していただきましたが、対象文書が大きいのと他の文書などにも応用させたい為にも、やはりVBAプログラムでお願いしたいと思います。