(VBA) 字幕の内容が複数行の場合、1行に集約化

質問

現在、字幕翻訳（英語＞日本）で字幕ファイル（テキストファイル）を補助ツールで
テキストファイル内の特定文字列を他の文字列に置き換える作業を行っています。

その後、置き換え終了後のファイルをEXCELのシートに読み込ませているのですが
補助ツールでの処理をEXCEL(VBA)で処理できないか考えています。

字幕ファイル(SRT形式)は、

　通し番号（連番）
　字幕の表示時間（タイムコード）
　字幕の内容（表示文字列＝テキスト情報）
　改行文字

'---------------------------------
SRTの例
1
00:05:00,400 --> 00:05:15,300
This is an example of a subtitle.

2
00:05:16,400 --> 00:05:25,300
This is an example of a subtitle - 2nd subtitle.

3
00:05:40,200 --> 00:05:41,0250
This is an example of a subtitle -
3rd subtitle.

'-----------------------------------
やりたい作業は、以下の作業です。

１）SRTの例の３番目のを見ると「字幕の内容」の部分の最後に改行コード有って
次の行に引き続き「字幕の内容」があります。
つまり、「字幕の内容」が複数行存在している。
この場合は、
　文字列の最後の改行コードを半角スペースに置き換えて
　1行の「字幕の内容」にコンバートする
（1番目や2番目のように1行に）

結果、
This is an example of a subtitle - 3rd subtitle.

Sheet1のA列にコンバート前のテキストファイルが読み込み済みであるとして
「字幕の内容」が複数行の部分を1行にするコードを摸索していますが
どうも「字幕の内容」部分が複数行かをチェックする方法が思いつきません。

何かアドバイスがあればお願いします。

最終的には、SRTフォーマットで別シートに1行にした「字幕の内容」を書き出すようにしたい。

「字幕の内容」部分が複数行の場合、通常はあっても2行までと思われますが
3行目以降が無いとは言い切れないので2行固定では無い方向でお願いします。

回答No.6

kkkkkm · ベストアンサー

データ量が多いのでしょうか。

Transpose関数は65537を超えるとエラーが出るという情報がありました。
セルアクセスに変更しようと思いましたが、データ量が多いと遅くなると思いますので最後に2次元配列に入れてTranspose関数を使わないようにしました。

変更点は、途中のjmojiをtmpに変更して最後にtmpのデータをjmojiに入れてます。

Sub Test2()
Dim i As Long, j As Long, k As Long
Dim lastRow As Long
Dim tb As Variant
Dim tmp() As String, jmoji As Variant

k = 0
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'セルのデータを2次元配列に
tb = Range(Cells(1, "A"), Cells(lastRow, "A")).Value

For i = LBound(tb, 1) To UBound(tb, 1)
If IsNumeric(tb(i, 1)) And Not IsEmpty(tb(i, 1)) Then
ReDim Preserve tmp(k)
'字幕はセクションの数値の2行あとのお約束なのでそこからはじめる
For j = i + 2 To UBound(tb) 'いつまで続くのか分からないのでとりあえず最後まで
'とりあえず最後までだけど
'それまでにセクション区切りの空白があるお約束なので
'途中のセクションは最後まで行かずにループを抜ける
If IsEmpty(tb(j, 1)) Then
Exit For
End If
'空白になるまで文字を連結する3rd subtitle.の前にスペースがあったのでそれを削除するためにTrim
tmp(k) = tmp(k) & " " & Trim(tb(j, 1))
Next
tmp(k) = Trim(tmp(k))
i = j
k = k + 1
End If
Next

Columns("B").ClearContents

ReDim jmoji(1 To UBound(tmp) + 1, 1 To 1)
For i = 1 To UBound(tmp) + 1
jmoji(i, 1) = tmp(i - 1)
Next

Cells(1, "B").Resize(UBound(jmoji, 1), 1).Value = jmoji

End Sub

お礼

ステップ実行する事で原因が判明しました。

ステップ実行でローカルウインドウを観察すると
セクションを分ける区切りを認識できないので
jmojiに次から次へと文字列を加えているようです。

つまり
　If IsEmpty(tb(j, 1)) Then
を見直す必要があると思い

If tb(j, 1) = "" Then
に変更するとエラー無く上手く処理できました。

読み込むテキストファイルによるのか？
読み込んだ後の区切り記号の選定が難しいです。

テキストエディターから文字列群をA列にコピペする場合と
FileSystemObjectオブゼクトでファイルを読み込む場合とでは
区切り文字が違うようです。

回答No.7

kkkkkm

> If tb(j, 1) = "" Then
> に変更するとエラー無く上手く処理できました。

それはよかったです。
=""とIsEmptyは違うものと昔読んだ記憶があったのでコンマ一秒くらい考えたのですが、うまくいったしIsEmptyの方がカッコイイとか思ったのでIsEmptyにしてました。

=""の方が安全そうですね。

補足

>=""の方が安全そうですね

たまたま、まぐれ当たりで上手くいっただけです。

空白セルの判別と言うので以下を参照しましたが
結局、=""とIsEmptyの違いは判りませんでした。

https://excel-ubara.com/excelvba4/EXCEL276.html

試しにテキストエディターからコピペした場合で同じコードを利用して処理してみましたが
If tb(j, 1) = "" Then　で、エラー無く処理できました。
（もちろん、 If IsEmpty(tb(j, 1)) Thenでもエラー無く処理できました。）

結論として、アドバイスと同じく=""を使う方が良さそうです。

回答No.5

kkkkkm

もうし分けない、また訂正

出力したデータの頭に半角スペースが残ってましたので

i = j
k = k + 1

のところを

jmoji(k) = Trim(jmoji(k))
i = j
k = k + 1

に変更してください。

あと

現状では問題ないと思いますがセクションに入った後にReDimした方がいいと思うので。

For i = LBound(tb) To UBound(tb)
ReDim Preserve jmoji(k)
If IsNumeric(tb(i, 1)) And Not IsEmpty(tb(i, 1)) Then

を

For i = LBound(tb, 1) To UBound(tb, 1)
If IsNumeric(tb(i, 1)) And Not IsEmpty(tb(i, 1)) Then
ReDim Preserve jmoji(k)

お礼

すいません。

No1.のお礼で記載したコードに一部ミスがありました。
以下に変更済みです。

jmoji = Cells(tmp, "A").Offset(2) & " " & Cells(tmp, "A").Offset(3) & " " & Cells(tmp, "A").Offset(4)

コード修正後にNo2のデータで試した結果
確かにご指摘のように3の範囲が抽出されませんでした。

原因調査後のコード修正を考える前にkkkkkmさんから直ぐに解決策のコードが出ましたので試した。
（No2＞3＞4＞5の修正こみこみ）

結果、上手く３が抽出できない問題も無く希望の形式で抽出が完了しました。

これから、実際の字幕DATAで実際に検証を始めます。
少しお時間をください。

補足

実際の字幕で検証し始めましたが、以下のコードでエラー出ます。
Cells(1, "B").Resize(UBound(jmoji) + 1, 1).Value = WorksheetFunction.Transpose(jmoji)

worksheetFunctionクラスのTransposeプロパティを取得できません。

どこかチェックすべき事項があればアドバイスお願いします。

Sub Test_kkkkm()
Dim i As Long, j As Long, k As Long
Dim lastRow As Long
Dim tb As Variant
Dim jmoji() As String

k = 0
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'セルのデータを2次元配列に
tb = Range(Cells(1, "A"), Cells(lastRow, "A")).Value

For i = LBound(tb, 1) To UBound(tb, 1)
If IsNumeric(tb(i, 1)) And Not IsEmpty(tb(i, 1)) Then
ReDim Preserve jmoji(k)

'字幕はセクションの数値の2行あとのお約束なのでそこからはじめる
For j = i + 2 To UBound(tb) 'いつまで続くのか分からないのでとりあえず最後まで
'とりあえず最後までだけど
'それまでにセクション区切りの空白があるお約束なので
'途中のセクションは最後まで行かずにループを抜ける
If IsEmpty(tb(j, 1)) Then
Exit For
End If

'空白になるまで文字を連結する3rd subtitle.の前にスペースがあったのでそれを削除するためにTrim
jmoji(k) = jmoji(k) & " " & Trim(tb(j, 1))
Next
jmoji(k) = Trim(jmoji(k))
i = j
k = k + 1
End If
Next
Columns("B").ClearContents

'1次元配列をセルに書き込むためにTranspose使う
Cells(1, "B").Resize(UBound(jmoji) + 1, 1).Value = WorksheetFunction.Transpose(jmoji)

End Sub

回答No.4

kkkkkm

回答No.1の微妙な訂正です。

省略した形なので問題はないのですが

よろしければ
LBound(tb) To UBound(tb)
を
LBound(tb, 1) To UBound(tb, 1)
にしておいてください。

回答No.3

kkkkkm

回答No.2の訂正です。

現状だと
外の
For i = LBound(tb) To UBound(tb)
このループは
00:05:00,400 --> 00:05:15,300
This is an example of a subtitle.1
1rd subtitle.

ここを見なくていい(jで回っているとこ)のに無駄に見ていますので

k = k + 1

のところにi = j を追加してもらって

i = j
k = k + 1

最後の

Cells(1, "C").Resize(UBound(jmoji), 1).Value = WorksheetFunction.Transpose(jmoji)

を

Cells(1, "C").Resize(UBound(jmoji) + 1, 1).Value = WorksheetFunction.Transpose(jmoji)

に変更してください。

回答No.2

kkkkkm

1
00:05:00,400 --> 00:05:15,300
This is an example of a subtitle.
1rd subtitle.

2
00:05:16,400 --> 00:05:25,300
This is an example of a subtitle - 2nd subtitle.

3
00:05:40,200 --> 00:05:41,0250
This is an example of a subtitle -
3rd subtitle.
3rd subtitle.
3rd subtitle.

4
00:05:40,200 --> 00:05:41,0250
This is an example of a subtitle -
4rd subtitle.

上記のデータでなぜか3の範囲が書き込まれずに

This is an example of a subtitle. 1rd subtitle.
This is an example of a subtitle - 2nd subtitle.
This is an example of a subtitle - 4rd subtitle.

こうなりました。

訂正箇所が分からないのでこちらで試してみてください。C列に書き込みます。

Sub Test()
Dim i As Long, j As Long, k As Long
Dim lastRow As Long
Dim tb As Variant
Dim jmoji() As String

k = 0
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
'セルのデータを2次元配列に
tb = Range(Cells(1, "A"), Cells(lastRow, "A")).Value

For i = LBound(tb) To UBound(tb)
ReDim Preserve jmoji(k)
If IsNumeric(tb(i, 1)) And Not IsEmpty(tb(i, 1)) Then
'字幕はセクションの数値の2行あとのお約束なのでそこからはじめる
For j = i + 2 To UBound(tb) 'いつまで続くのか分からないのでとりあえず最後まで
'とりあえず最後までだけど
'それまでにセクション区切りの空白があるお約束なので
'途中のセクションは最後まで行かずにループを抜ける
If IsEmpty(tb(j, 1)) Then
Exit For
End If
'空白になるまで文字を連結する3rd subtitle.の前にスペースがあったのでそれを削除するためにTrim
jmoji(k) = jmoji(k) & " " & Trim(tb(j, 1))
Next
k = k + 1
End If
Next
Columns("C").ClearContents
'1次元配列をセルに書き込むためにTranspose使う
Cells(1, "C").Resize(UBound(jmoji), 1).Value = WorksheetFunction.Transpose(jmoji)

End Sub

回答No.1

kkkkkm

通し番号（連番）から始まって3行目(最初の字幕の内容)以降は、改行文字だけの行が出るまで前の行に追加し、改行文字だけの行が出たら次のセクションという感じでいけそうな気もしますがどうでしょう。

お礼

kkkkkmさん、お世話になります。

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

試行錯誤して以下のコードでを考えてみました。
連番の行番号を配列に読み込んで
連番行の下に改行（EXCELでは””の行）がどこにあるかで
　「字幕の内容」を連結すると言う思考です。

無駄が多いように思えますがいかがでしょうか　？

Option Explicit

Sub AddConsecutiveNumbers()
Dim i As Long, j As Long
Dim lastRow As Long
Dim tb() As Variant
Dim jmoji As String

lastRow = Cells(Rows.Count, "A").End(xlUp).Row
ReDim tb(lastRow)

'通し番号の行（番号）を求める
j = 0
For i = 1 To lastRow
If Cells(i, "A").Value = Range("A1") + j Then
tb(i) = Cells(i, "A").Row
'Debug.Print tb(i)
j = j + 1
Else
'
End If
Next

'----------------------------------------
Dim temp() As Variant

' emptyでない配列の数を数える
j = 0
For i = LBound(tb) To UBound(tb)
If Not IsEmpty(tb(i)) Then
j = j + 1
End If
Next i

' emptyでない配列をtemp()にコピー
ReDim temp(1 To j)

j = 0
For i = LBound(tb) To UBound(tb)
If Not IsEmpty(tb(i)) Then
j = j + 1
temp(j) = tb(i)
End If
Next i

' tb()を再構築
ReDim tb(1 To j)
For i = LBound(tb) To UBound(tb)
tb(i) = temp(i)
Next i

'-----------------------------
Columns("B").ClearContents

'b列に字幕の内容のみ書き出し
Dim tmp As Long
j = 1
For i = 1 To UBound(tb)
tmp = tb(i)

If Cells(tmp, "A").Offset(2) <> "" And Cells(tmp, "A").Offset(3) = "" Then
jmoji = Cells(tmp, "A").Offset(2)
Cells(j, "B") = jmoji
j = j + 1

ElseIf Cells(tmp, "A").Offset(3) <> "" And Cells(tmp, "A").Offset(4) = "" Then
jmoji = Cells(tmp, "A").Offset(2) & " " & Cells(tmp, "A").Offset(3)
Cells(j, "B") = jmoji
j = j + 1

ElseIf Cells(tmp, "A").Offset(4) <> "" And Cells(tmp, "A").Offset(5) = "" Then
jmoji = Cells(tmp, "A").Offset(2) & " " & Cells(tmp, "A").Offset(3) & Cells(tmp, "A").Offset(4)
Cells(j, "B") = jmoji
j = j + 1

End If
Next
End Sub