それぞれテキストファイに区切って出力

質問

添付画像のような構成で
　C列数値（D列の文字数の総計）を上から順番に合計して300を超えるとB列にその合計を書き出すようにしました。
　（コード SumIfOver300)

わかりやすいようにA列にそれぞれを塗分けしています。

1) 現在は、手動ですがこれをVBAで自動で処理したい。
（添付図は、３色ですが境目が解ればいいので2色でもOKです。）

2) 塗分け後に塗分けされたD列の部分を一つのテキスト群としてそれぞれ別ファイル（テキストファイル）に区切って出力したい。

添付図で言うといかのように出力
　D2：D7　 001_text.txt
D8:D12 002_text.txt
D13:D15 003_text.txt

Sub SumIfOver300()
Dim lastRow As Long
Dim sum As Long
Dim i As Long

lastRow = Cells(Rows.Count, "C").End(xlUp).Row
sum = 0

For i = 1 To lastRow
sum = sum + Cells(i, "C").Value
If sum > 300 Then
Cells(i, "B").Value = sum
sum = 0
End If
Next i
End Sub

回答No.28

kkkkkm · ベストアンサー

> 　</i>は、
> 　　fileContent = Replace(fileContent, "/", "%EF%BC%8F")
> 　　実際は、< / i>に先に変換されているので無駄なコードになっているようです。

上記を
fileContent = Replace(fileContent, "</i>","")
の後に実行すればいいのではないですか。
置換の順番は、文字数の多いものから先にするといいのではないでしょうか。
ただ
「%」は必ず一番最初に置換
は、あのグループの中で他の置換の結果に「%」が含まれるから、それを置換しないようにするためです。

> 事前にReplaceで削除しておきたいのですが
> どのようなコードになりますか　？

fileContent = Replace(fileContent, "</i>","")
と同じようにすればいいと思います。

お礼

ありがとうございます。

難しく考えていました。
アドバイスのように削除記号をひとつずつコードで追加すれば良いのですね。

（　<*>　のようにワイルドカード的な処理を想定していました。）

以下のコードに変更してしばらくテストしてみます。

fileContent = Replace(fileContent, "%", "%25")

fileContent = Replace(fileContent, "<i>", "")
fileContent = Replace(fileContent, "</i>", "")

fileContent = Replace(fileContent, "<b>", "")
fileContent = Replace(fileContent, "</b>", "")

fileContent = Replace(fileContent, "<BR>", "")

fileContent = Replace(fileContent, "#", "%23")
fileContent = Replace(fileContent, "/", "%EF%BC%8F")

pStr = Replace(Replace(Replace(fileContent, vbCr, "%0D"), vbLf, "%0A"), " ", "%20")

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

回答No.27

kkkkkm

> 結果ですが、今回も前回の以下の参考図と同じ結果です。

データが渡されている以上、DeepLの結果に関しては、なぜそうなるのかはご自身で調べてください。

お礼

>DeepLの結果に関しては、なぜそうなるのかはご自身で調べてください。

確かにおっしゃるとうりです。

DeepLに翻訳すべき英文が渡されている以上、それから先はDeepLの問題ですね。

ダメもとで< i >< / i > を削除して渡すようにすると翻訳されました。

具体的には、以下のコード追加しました。

fileContent = Replace(fileContent, "<i>", "")
fileContent = Replace(fileContent, "</i>","")

　</i>は、
　　fileContent = Replace(fileContent, "/", "%EF%BC%8F")
　　があるので
　　実際は、< / i>に先に変換されているので無駄なコードになっているようです。

そこで調べてみると字幕のフォーマットでは、他に以下のような書式があるようです。

< b >< / b >　　太字
< i >< / i > 　イタリック体
<BR>　　　　　　改行

いずれにしても　<文字列>は、翻訳時には不具合が出るようなので
事前にReplaceで削除しておきたいのですが
どのようなコードになりますか　？

回答No.26

kkkkkm

fileContent = Replace(fileContent, "%", "%25")
fileContent = Replace(fileContent, "#", "%23")
fileContent = Replace(fileContent, "/", "%EF%BC%8F")

pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20")
WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr

fileName = Dir

です。

補足

ありがとうございます。

アドバイスに従ってコードの位置を変更しました。

WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr

fileName = Dir

変更後に同じサンプルで試してみました。

結果ですが、今回も前回の以下の参考図と同じ結果です。
　参考画像　https://imgur.com/rqbRBht

回答No.25

kkkkkm

> 翻訳が１行に結合された結果になります。

なるほど、改行は無いと駄目なんですね。

vbCr,vbLfそれぞれを削除するのではなく、%付きのコードにして送ってやるといけます。

pStr = Replace(Replace(Replace(fileContent, vbCr, "%0D"), vbLf, "%0A"), " ", "%20")

> fileContent = Replace　のコード位置は、以下で間違いないでしょうか　？

その下に

fileName = Dir

があれば間違いないと思います。

お礼

ありがとうございます。

教えてもらったコードに変更に変更して、
　行数の少ないサンプル（1-10）では、うまく処理できたので行数の多い３つのサンプルでTest()を試してみました。

①　サンプル数　14
②　サンプル数　17
③　サンプル数　20

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

fileContent = Replace(fileContent, "%", "%25")
fileContent = Replace(fileContent, "#", "%23")
fileContent = Replace(fileContent, "/", "%EF%BC%8F")

fileName = Dir

pStr = Replace(Replace(Replace(fileContent, vbCr, "%0D"), vbLf, "%0A"), " ", "%20")

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

結果、以下参考画像のように　不思議な結果になりました。

参考画像

https://imgur.com/rqbRBht　　（test()経由でのDeepLの翻訳結果）

④　サンプル数　14　では、翻訳された
⑤　サンプル数　17　では、13-17　が　翻訳されない
⑥　サンプル数　20　では、13-17　が　翻訳されない

https://imgur.com/CEIbJlR　　（この参考画像は、同じサンプルで直接DeppLで翻訳した場合、test()の場合と微妙に違う結果）

10までは翻訳されていますが
①　サンプル数　14　では、11-13　が　翻訳されないが　14　は、翻訳された
②　サンプル数　17　では、11-16　が　翻訳されないが　17　は、翻訳された
③　サンプル数　20　では、11-20　が　翻訳されない
　　　（①、②のパターンからでは、20は翻訳されると思いましが翻訳されなかった）

翻訳される場合とされない場合の差がどこにあるのか ？
なんだか良くわからない結果になりました。

回答No.24

kkkkkm

> print #2, newText

#2のファイルがどこにあるのか見えません。

Replaceすればいいだけじゃないですか。「/」はコード指定にしても駄目っぽいのでとりあえず全角に(UTF-8のコード)
「%」は必ず一番最初に置換

fileContent = Replace(fileContent, "%", "%25")
fileContent = Replace(fileContent, "#", "%23")
fileContent = Replace(fileContent, "/", "%EF%BC%8F")
pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20")

ASCIIコード表
https://e-words.jp/p/r-ascii.html

お礼

>#2のファイルがどこにあるのか見えません。

AI処理を参考にしましたが、付け焼刃はダメですね。

>Replaceすればいいだけじゃないですか。

今回から、実DATAの短縮ミニ版のテキストを利用してテストを始まました。

TEST()マクロで直接文字列をReplace関数で処理すれば良いとのアドバイスでコードを書き換えて実行しました。
結果は、思ったような結果になりません。

改行コードが無くなるのか？
翻訳が１行に結合された結果になります。
（これは、replace関数のコードを記入した場合も、無い場合も同じ結果でした。）

以下の参考画像を参照ください。
https://imgur.com/EsymXr3

fileContent = Replace　のコード位置は、以下で間違いないでしょうか　？
（また間違えている可能性があるので確認したいです。）

Do While fileName <> ""
Open folderPath & fileName For Input As #1
'変更（No22)
fileContent = ""
Do While Not EOF(1)
Tmp = Input(1, #1)
fileContent = fileContent & Tmp
Loop

Close #1

fileContent = Replace(fileContent, "%", "%25")
fileContent = Replace(fileContent, "#", "%23")
fileContent = Replace(fileContent, "/", "%EF%BC%8F")

pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20")
WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr

回答No.23

kkkkkm

No.21のお礼のコードよく見てなかったのですが

何故に

pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20")

WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr

この2行の位置が変わってるのですか。

また、文中に
/#があればそれ以降は無視されます。
%があれば全文翻訳画面になにも表示されません。

Replaceで何かに変換してください。

あとはこちらのデータを参考にして調べてください。

URLで使用できる文字、使用できない文字
https://www.petitmonte.com/internet_blog/url_usecharacter.html

お礼

全く、今回も初歩的なミスで時間を費やしてしまいお詫び申し上げます。

>何故にこの2行の位置が変わってるのですか。

多分、No21のコードの訂正時にコピペミスをしたのだと思います。

２つのコードを正規の位置に戻してダミーDATAで正常に処理されるのを確認しました。

ダミーDATAで正常に処理されたので実DATAで翻訳する前に
アドバイスにあったダメ文字（/#%）が存在するか？チェックするコードを作成して
チェックすると複数存在するのを確認しました。

次にダメ文字を半角スペースに変換する下記コードを作成してみましたが
今度のコードは、下記エラーが発生しました。

print #2, newText

実行エラー　52
　ファイル名または番号が不正です。

コードの不備をアドバイスをお願いします。

「使用できる文字、使用できない文字」のURLを見ると
今回ダメ文字と指定した以外にも候補に上げなければいけないと思われる文字列（記号）が記載されていますが
数が多いので今回は、とりあえず3文字をターゲットにしました。

Sub ダメ文字を半角スペースに変換()
Dim myFolder As String
Dim myFile As String
Dim text As String
Dim newText As String
Dim myExtension As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim arr As Variant

'指定のフォルダを設定
myFolder = "C:\Users\TAC_\DeskTop\test\"
'指定の拡張子を設定
myExtension = "*.txt"
'指定の文字列を設定
arr = Array("/", "%", "#")

'指定フォルダ内のすべてのファイルを処理
myFile = Dir(myFolder & myExtension)

Do While myFile <> ""
'ファイルを開く
Open myFolder & myFile For Input As #1

'ファイルの内容を読み込む
Do Until EOF(1)
Line Input #1, text
newText = ""
'文字列を検索して置換する
For i = 1 To Len(text)
For j = 0 To UBound(arr)
If Mid(text, i, 3) = arr(j) Then
newText = newText & " "
i = i + 2
Exit For
End If
Next j
If i <= Len(text) Then
newText = newText & Mid(text, i, 1)
End If
Next i

'置換後の文字列をファイルに書き込む
Print #2, newText
Loop

'ファイルを閉じる
Close #1
Close #2

'元のファイルを削除
Kill myFolder & myFile

'置換後のファイルを元のファイル名で保存
Name myFolder & "temp.txt" As myFolder & myFile

'次のファイルを処理
myFile = Dir
Loop

MsgBox "ダメ文字の半角スペースへの変換が終了しました。"
End Sub

回答No.22

kkkkkm

fileContent = Input$(LOF(1), 1)

のところを一行ずつ読み込みに変更してみてください。

fileContent = ""
Do While Not EOF(1)
Tmp = Input(1, #1)
fileContent = fileContent & Tmp
Loop

あとは、ファイルをそれぞれ単体で実行して、DeepLが開かないファイルを限定して
ファイルの中身の状態、うまくいくファイルとの比較
その時の
fileContent
と
pStr
の内容がどうなっているのか確認しないと、こちらでは問題がないので原因が分かりません。

お礼

No22によるアドバイスでコードを修正しました。

エラー「ファイルにこれ以上データがありません。」は出なくなりました。

DeepL（画面）は開かないことはありませんが、
DeepL画面の左側に何も読み込まれていないので
　右側の翻訳画面にも何も表示されない状態で以前と変化はありません。

kkkkkmさんの環境では、問題なく作動しているとの事なので
私の環境だけの問題化も知れません。

https://imgur.com/PAeiWlb　で示した同じテキストファイルを利用して
コードをF8でステップ実行した動画（一部編集あり）のURLを添付いたします。

fileContentはdo文で随時読み込まれているようですが
Pstrはずっと""のままで変化がありません。

お手数をおかけしますが、以下の動画を見て何かわかる事はありますか　？

動画のダウンロードは、以下のURLの中ほどある動画(2:24)が参考になると思います
https://gigafile.ltd/gigafile-howto/

UPした動画のURL（アクセス用）
https://21.gigafile.nu/0609-d817d6293422d04c55f86bc174961a914

回答No.21

kkkkkm

No.20の訂正です。

pStr = Replace(Replace(Replace(Replace(fileContent, vbCrLf, ""), vbCr, ""), vbLf, ""), " ", "%20")

は

pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20")

でいいと思います。後から単純にvbCrを追加したので「vbCrLf」と「vbCr&vbLf」が重複するのが頭から抜けてました。

お礼

コードの修正ありがとうございます。
（回答20から21へのコード修正を反映済みです）

実DATAは、ファイル数が10以上あるので数が少ないダミーDATAで試してみました。
参考画像は、2つのテキストファイル（それぞれをテキストエディターに読み込んで開いた状態を合成）

Test()を実行すると、DeepL画面が切り替わっても
　DeepL画面の左側に何も読み込まれていないので右側の翻訳画面にも何も表示されない状態で以前と変化はありません。

以下のコードで
fileContent = Input$(LOF(1), 1)

エラーがでました。

　実行じエラー 62
　ファイルにこれ以上データがありません。

エラーは、001_textを読み込んで何も翻訳されず、「次の翻訳」でOKをクリックした後で発生。
添付画像のローカルウインドウを参照ください。

　fileName 002_text.txt
fileContent : "Pink Floyd are an English rock band formed in London in 1965. ---------　（続く）
　i=0

素人考えでは、002_text.txtを読みだす直前でエラーが発生しているようです。

Sub Test()
Dim folderPath As String
Dim fileName As String
Dim fileContent As String
Dim WSH
Dim i As Long
Dim pStr As String

Set WSH = CreateObject("Wscript.Shell")

folderPath = "C:\Users\TAC_\DeskTop\test\"
fileName = Dir(folderPath & "*.txt")
pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20")

WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr
Do While fileName <> ""
Open folderPath & fileName For Input As #1
fileContent = Input$(LOF(1), 1)
Close #1

fileName = Dir
If fileName <> "" Then
If MsgBox("次の翻訳", vbOKCancel, vbQuestion) = vbCancel Then
Exit Do
End If
Else
MsgBox "終了", vbInformation
End If
Loop
Set WSH = Nothing
End Sub

補足

すいません。
参考画像を添付するのを忘れました。

以下が参考画像です。

https://imgur.com/PAeiWlb

回答No.20

kkkkkm

セルの中の改行はLfのまま出力されて、セルと次のセルの間はCrLfで出力されるのでファイルの中で両方が混在してました。
改行をURLに付けるとよくないと思って、外すようにしたのですが、私の環境だと改行があってもDeepLは開いたので気が付きませんでした。

古いマック(多分そのデータは扱わないと思うのですが)ではCrが改行みたいなので、それも入れておきました。

Dim pStr As String
を追加して
pStr = Replace(Replace(Replace(Replace(fileContent, vbCrLf, ""), vbCr, ""), vbLf, ""), " ", "%20")
WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr
にしてみてください。

Replaceがくどいですが、一括で指定できる方法があるのかないのか、未調査です。

回答No.19

kkkkkm

> この表示が出なくなるようにコードを修正したいのですがお願いできますか　

確認メッセージを非表示にする（DisplayAlertsプロパティ）
https://www.moug.net/tech/exvba/0150081.html

でどうでしょうか。

また、直接テキストファイルを開いてその内容を翻訳させるというのはいかがですか。
なお、テキストファイルを開いてデータを取得するところは、以前NuboChanさんが「AIさんに回答を求めた結果」と回答したコードからいただきました。

Sub Test()
Dim folderPath As String
Dim fileName As String
Dim fileContent As String
Dim WSH

Set WSH = CreateObject("Wscript.Shell")
folderPath = "C:\Ok\test\test\"
fileName = Dir(folderPath & "*.txt")
Do While fileName <> ""
Open folderPath & fileName For Input As #1
fileContent = Input$(LOF(1), 1)
Close #1
WSH.Run "https://www.deepl.com/translator#en/ja/" & Replace(Replace(fileContent, vbCrLf, ""), " ", "%20")
fileName = Dir
If fileName <> "" Then
If MsgBox("次の翻訳", vbOKCancel, vbQuestion) = vbCancel Then
Exit Do
End If
Else
MsgBox "終了", vbInformation
End If
Loop
Set WSH = Nothing
End Sub

お礼

アドバイス感謝します。

LoadFilesToSheets()にアドバイスにあるDisplayAlertsプロパティを利用すべくコードに追加しましたが、

以下の表示は、依然として出現します。

「このブックには、安全でない可能性のある外部ソースへのリンクが一つ以上含まれます。
　リンクを信頼できる場合、リンクを更新して最新データを取り込みます。信頼できない場合は、データをそのまま手元で処理してかまいません。」

但し、以前は上記の次に出現していた不要な注意書きらしき表示は出なくなりました。

読み込むファイルが多いとシートを追加するところで
感覚的には「うねうね」とシート追加画面が消えたり出現したりして気持ちが悪いので
アドバイスにある「直接テキストファイルを開いてその内容を翻訳させる」ように変更したいと思います。

つまり、LoadFilesToSheets()の開発は停止したいと思います。

'---------------------------------------------------------

直接テキストファイルを開いてその内容を翻訳させる為に
　No19のtest()を実行しましたが
　　fileNameに以前のコードで作成済みの分割された最初のテキストファイル名が指定されているのがローカルウインドウで確認済みですが
　　画面が切り替わっても
　　DeepL画面の左側に何も読み込まれていないので右側の翻訳画面にも何も表示されていません。

多分原因は、以下のコードが原因だと思うのですが　？
WSH.Run "https://www.deepl.com/translator#en/ja/" & Replace(Replace(fileContent, vbCrLf, ""), " ", "%20")

ファイル内のテキストファイルには、改行されたセルがあるのでNO18のように変更する必要があると思われます。
（でも、コードにはｖｂCrLfの表記があるので改行対策済みのコードだとも考えられるし.... ????）

そうではなく他に問題があるのでしょうか　？

Sub LoadFilesToSheets()
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook
Dim ws As Worksheet

folderPath = "C:\Users\TAC_\DeskTop\test\" '***は伏字
fileName = Dir(folderPath & "*.*")

Application.DisplayAlerts = False

Do While fileName <> ""
Set wb = Workbooks.Open(folderPath & fileName)
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = fileName
wb.Sheets(1).UsedRange.Copy ws.Range("A1")
wb.Close False
fileName = Dir
Loop

Application.DisplayAlerts = True

End Sub

回答No.18

kkkkkm

英文が改行有だったりする場合(セルにある場合)は

WSH.Run "https://www.deepl.com/translator#en/ja/" & Replace(Cells(i, "A"), " ", "%20")
を
WSH.Run "https://www.deepl.com/translator#en/ja/" & Replace(Replace(Cells(i, "A").Value, vbLf, ""), " ", "%20")

お礼

kkkkkmさん、見捨てないで善後策を見出していただきありがとうございます。

No17,No18のコードを私なりに利用できる方法として

総文字数が4000文字で塗分けしてテキストファイルに分割して出力しているので
これをシートに読み込んでNo17(18)のコードを利用してDeepLに翻訳させればかなり手抜きができると思います。
（最終な翻訳の結果はコピペで保存する手間は必要ですが.....）

そこで
　指定フォルダー内のファイルを
　現在のブックにファイル名をシート名にして新しく読み込んで行くマクロを以下のように作成しましたが

不備があるのか、以下の表示が出ます。
（この表示以外にも続けて不要な注意らしき表示が出ます。）

「このブックには、安全でない可能性のある外部ソースへのリンクが一つ以上含まれます。
　リンクを信頼できる場合、リンクを更新して最新データを取り込みます。信頼できない場合は、データをそのまま手元で処理してかまいません。」

この表示が出なくなるようにコードを修正したいのですがお願いできますか　？

Sub LoadFilesToSheets()
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook
Dim ws As Worksheet

folderPath = "C:\Users\***\DeskTop\test\"　　'***は伏字
fileName = Dir(folderPath & "*.*")

Do While fileName <> ""
Set wb = Workbooks.Open(folderPath & fileName)
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = fileName
wb.Sheets(1).UsedRange.Copy ws.Range("A1")
wb.Close False
fileName = Dir
Loop
End Sub