（VBA)FORMATを変換して書き出したい

質問

以下のようなテキストファイルを

CHAPTER01=0:00:00.000
CHAPTER01NAME=test_001
CHAPTER02=0:04:02.719
CHAPTER02NAME=test_456
CHAPTER03=0:08:33.859
CHAPTER03NAME=test_741

下記のようなフォーマットにEXCELのVBAを利用して変更してテキストファイルで書き出したい
最初のモデルになるようなマクロコードを教えてください。

1
00:00:00,000 --> 00:00:10.000
test_001

2
00:04:02,719 --> 00:04:12.719
test_456

3
00:08:33,859 --> 00:08:43.859
test_456

このように、番号、開始時間と終了時間、テキストの3つの要素があります。
時間は時:分:秒,ミリ秒の形式で表されます。
各要素は空白行で区切られます。

終了時間=開始時間+10秒(00:00:10.000)

’----------------------------

一応、何とか自前でコードは完成しましたが
運用上は問題なのですが算数的にはおこしな事になっています。

以下でDtime（10秒）を加算していますが
ws2.Cells(i, "B") = DateAdd("s", Dtime, ws2.Cells(i, "A"))

ws2.Cells(i, "A")　が　0:04:02.719　だとすると
0:04:12.719　になるはずが
実際は、ws2.Cells(i, "B")　は　
0:04:13.000　と小数点以下がゼロになっています。

訂正を及びコードに関してアドバイスあればお願いします。

Option Explicit

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ls As Long, i As Long

Set ws1 = Worksheets("DATA")
Set ws2 = Worksheets("Convert")

ls = ws1.Cells(Rows.Count, "A").End(xlUp).Row

Dim txt As String
Dim Dtime As String

ws2.Cells.Clear

ws2.Columns("A").NumberFormatLocal = "h:mm:ss.000"
ws2.Columns("B").NumberFormatLocal = "h:mm:ss.000"

For i = 1 To ls Step 2
'開始時間
txt = ws1.Cells(i, "A").Value
ws2.Cells(i, "A") = Mid(txt, InStr(txt, "=") + 1)

'表示時間指定　（任意）
Dtime = 10

'終了時間
ws2.Cells(i, "B") = DateAdd("s", Dtime, ws2.Cells(i, "A")) '開始時間に10秒を加算

'時間部（開始 --> 終了)
ws2.Cells(i, "C") = ws2.Cells(i, "A").Text & " --> " & ws2.Cells(i, "B").Text

'Title
txt = ws1.Cells(i + 1, "A").Value
ws2.Cells(i + 1, "C") = Mid(txt, InStr(txt, "=") + 1)
Next

'Plane Text 保存 -----------------
Dim R_data As Integer '行番号
R_data = 1

Open "C:\Users\ABC\Desktop\Plane_text.txt" For Output As #1

Do While ws2.Cells(R_data, "C") <> ""
Print #1, ws2.Cells(R_data, "C")

If R_data Mod 2 = 0 Then '2の倍数のとき
Print #1, "" '空白行を出力
End If

R_data = R_data + 1
Loop

Close #1

End Sub

’---------------------------------

回答No.2

kkkkkm · ベストアンサー

Excel ワークシートのセルに VBA の日付形式またはバリアント型の日付形式を割り当てようとすると、ミリ秒が最も近い秒に丸められます。
https://support.microsoft.com/ja-jp/topic/excel-%E3%83%AF%E3%83%BC%E3%82%AF%E3%82%B7%E3%83%BC%E3%83%88%E3%81%AE%E3%82%BB%E3%83%AB%E3%81%AB-vba-%E3%81%AE%E6%97%A5%E4%BB%98%E5%BD%A2%E5%BC%8F%E3%81%BE%E3%81%9F%E3%81%AF%E3%83%90%E3%83%AA%E3%82%A2%E3%83%B3%E3%83%88%E5%9E%8B%E3%81%AE%E6%97%A5%E4%BB%98%E5%BD%A2%E5%BC%8F%E3%82%92%E5%89%B2%E3%82%8A%E5%BD%93%E3%81%A6%E3%82%88%E3%81%86%E3%81%A8%E3%81%99%E3%82%8B%E3%81%A8-%E3%83%9F%E3%83%AA%E7%A7%92%E3%81%8C%E6%9C%80%E3%82%82%E8%BF%91%E3%81%84%E7%A7%92%E3%81%AB%E4%B8%B8%E3%82%81%E3%82%89%E3%82%8C%E3%81%BE%E3%81%99-4a0af2c5-78de-762f-6431-8669890f585b

これにしたらいけそうです。

ws2.Cells(i, "B").Value2 = DateAdd("s", Dtime, ws2.Cells(i, "A").Value2) '開始時間に10秒を加算

Dim Dtime As String
は
Dim Dtime As Long
じゃないでしょうか

お礼

毎度、kkkkkmさんからのアドバイスありがとうございます。

早速、いただいたコードを起動させてみましたが
mTxt = mInTxtFile.ReadAll　で

「ファイルにこれ以上データがありません 」のエラーが出ます。

私のコードもその後色々と不具合が見つかったので
現在は、以下のように修正しています。

先に、どうすべきか提案させて点を除けば何とか利用できるまでは来ていると思います。
（コードを確認していただけるならこちらのコードでお願いします。）

Option Explicit

Sub Test_2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ls As Long, i As Long

Set ws1 = Worksheets("DATA")
Set ws2 = Worksheets("Convert")

ls = ws1.Cells(Rows.Count, "A").End(xlUp).Row

Dim txt As String
Dim Dtime As Integer

ws2.Cells.Clear

ws2.Columns("A").NumberFormatLocal = "h:mm:ss.000"
ws2.Columns("B").NumberFormatLocal = "h:mm:ss.000"

Dim temp As String
For i = 1 To ls Step 2
'開始時間
txt = ws1.Cells(i, "A").Value
ws2.Cells(i, "A") = Mid(txt, InStr(txt, "=") + 1)

'表示時間(秒)指定　（任意）
Dtime = 10

'終了時間
ws2.Cells(i, "B") = DateAdd("s", Dtime, ws2.Cells(i, "A")) '開始時間に秒を加算

'時間部（開始 --> 終了) フォーマット一部変更
temp = ws2.Cells(i, "A").Text & " --> " & ws2.Cells(i, "B").Text
ws2.Cells(i, "C") = Replace(temp, ".", ",")

'Title
txt = ws1.Cells(i + 1, "A").Value
ws2.Cells(i + 1, "C") = Mid(txt, InStr(txt, "=") + 1)
Next

'Plane Text 保存 -----------------
Dim R_data As Integer '行番号
R_data = 1

Open "C:\Users\AAA\Desktop\Plane_text.srt" For Output As #1

Dim j As Integer
j = 1
For i = 1 To ls Step 2

Print #1, CStr(j) 'jの値を文字列に変換して半角の空白が出力されるないようにする
Print #1, ws2.Cells(i, "C")
Print #1, ws2.Cells(i, "C").Offset(1, 0)
Print #1, "" '区分用の空白行を追加して出力
j = j + 1
Next

Close #1

End Sub

回答No.5

kkkkkm

> Byte（0-255）でも十分なのですがInteger(-32768-32767)　に変更しました。

これですが、最近はLongの方が効率がいいみたいで
最近のバージョンではInteger型を指定しても自動的にLong型に変換されるらしいです。

VBAの整数型Integerがわかる！Long型・Byte型との違いも解説
https://www.tech-teacher.jp/blog/vba-integer/
【ExcelVBA】Integer型とLong型の使い分けは？処理速度が速いのは？
https://moripro.net/vba-integer-long/

お礼

ありがとうございます。
アドバイスで以下、理解できました。

「最近のバージョンではInteger型を指定しても自動的にLong型に変換されるようになっています。」

「ソースコードが長い場合には、Integer型をLong型に変換する手間のために処理が遅くなる可能性もあります。
実際のコードで整数型の変数を使用するときには、処理を高速化するため、Long型を指定するようにしましょう。」

メモリーの消費を昔よりも気にしなくても良くなった昨今では、Longで統一する事にします。

＞こちらもShft-JISなのですが何故なんでしょうね・・・。

不思議ですが、気にしないで忘れる事にします。

サンプルで上手く処理出来たので実際のケースで試用を初めてみます。

今回もお世話になりありがとうございました。

（実ケースで不具合が出た場合は、改めて相談させていただきたいと思います。）

回答No.4

kkkkkm

> 調べたら元のファイルがShift＿Jisの場合は破損するので

こちらもShft-JISなのですが何故なんでしょうね・・・。

> 以下のように9の次が1になりました。

そうですね。01とかの0を外そうとして0を単純に外したのが間違いでした。

どちらにしても、NuboChanさんのコードでいけるのですから忘れましょう。

回答No.3

kkkkkm

> 「ファイルにこれ以上データがありません 」のエラーが出ます。

そうですか何故なのでしょうね。単に一気に読み込むだけだと思いましたが忘れましょう。

> コードを確認していただけるならこちらのコードでお願いします。

なにか問題があるでしょうか。問題が無ければ変なところがあるとは思われないです。

お礼

的確なアドバイスありがとうございます。

以下のように.value2を追加して小数点以下も拾えるようになりました。
ws2.Cells(i, "B").Value2 = DateAdd("s", Dtime, ws2.Cells(i, "A"))

＞Dim Dtime As Long

Stringではおかしいです。
（それなのにエラーはでませんでした。不思議です。）

マイナスを設定する事は無いので
Byte（0-255）でも十分なのですがInteger(-32768-32767)　に変更しました。

＞そうですか何故なのでしょうね。
＞単に一気に読み込むだけだと思いましたが忘れましょう。

不思議なのは、エラーでると読み込むファイルが破損するのか？
中身が空のファイルになっています。

調べたら元のファイルがShift＿Jisの場合は破損するので
UTF＿8に変換したら上手く処理できました。

但し、以下のように9の次が1になりました。

9
00:43:18.447
12356

1
00:50:51.857
78956

回答No.1

kkkkkm

あら、できたのですね。テキストからテキストだと思ったのでエクセル使わずにやってました。
1とか2とかいらないのでしたか。
とりあえず出しておきます。暇なときに時間つぶしでやってみてください。

Ifがやたら多いけど考えるのに疲れたのでまとめてません。数値の重複見つけるのにDirectory使おうと思いましたがなんか遅くなると聞いたので使わすにIfでやってます。変数名とかも適当です(いつもの事ですが)

0:00:00.000 --> 0:00:10.000
は
0:00:00.000 を 0:00:10.000にするのだよという意味だと思っておりました。そのようになってます。

NuboChanさんのコードは後で確認してみます。

Sub Test()
Dim mFSO As Object, mInTxtFile As Object, mOutTxtFile As Object
Dim intmp As Variant, outtmp As Variant
Dim mTxt As String, mOutTxt As String
Dim i As Long, j As Long

Set mFSO = CreateObject("Scripting.FileSystemObject")
Set mInTxtFile = mFSO.OpenTextFile("C:\Ok\test1215i.txt")
Set mOutTxtFile = mFSO.OpenTextFile("C:\Ok\test1215o.txt", 2, True)

mTxt = mInTxtFile.ReadAll
intmp = Split(mTxt, vbCrLf)
ReDim outtmp(2)
j = 0
For i = LBound(intmp) To UBound(intmp)
If InStr(intmp(i), "=") > 0 Then
outtmp(j) = Split(intmp(i), "=")(0)
outtmp(j + 1) = Split(intmp(i), "=")(1)
If InStr(outtmp(j), "CHAPTER") > 0 Then
outtmp(j) = Replace(Replace(Replace(outtmp(j), "CHAPTER", ""), "NAME", ""), "0", "")
End If
j = j + 2
ReDim Preserve outtmp(j + 2)
End If
Next

For i = LBound(outtmp) To UBound(outtmp)
If i = 0 Then
mOutTxt = mOutTxt & outtmp(i) & vbCrLf
ElseIf i Mod 2 = 0 Then
If i < UBound(outtmp) - 2 Then
If outtmp(i) = outtmp(i + 2) Then
mOutTxt = mOutTxt & outtmp(i) & vbCrLf
End If
End If
ElseIf i Mod 2 = 1 Then
If InStr(outtmp(i), ":") > 0 Then
Mid(outtmp(i), InStrRev(outtmp(i), ":") + 1, 2) = Val(Mid(outtmp(i), InStrRev(outtmp(i), ":") + 1, 2)) + 10
If InStr(outtmp(i), ":") = 2 Then
outtmp(i) = "0" & Format(outtmp(i), "00:00:00.000")
Else
outtmp(i) = Format(outtmp(i), "00:00:00.000")
End If
End If
mOutTxt = mOutTxt & outtmp(i) & vbCrLf
If i Mod 4 = 3 Then
mOutTxt = mOutTxt & vbCrLf
End If
End If
Next

mOutTxtFile.Write (mOutTxt)

mInTxtFile.Close
mOutTxtFile.Close

Set mInTxtFile = Nothing
Set mOutTxtFile = Nothing
Set mFSO = Nothing
End Sub