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

質問

添付画像のような構成で
　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.7

kkkkkm

o.6の訂正です。

> セルの形式が文字列ではないセルがあるたびに

「たびに」じゃなくて、あれば「A1から最終行まで一巡して、セルの書式をテキストに変更以降」を実行し、その後、形式が文字列ではないセルは現れなくなるので、「たびに」じゃなくなりますね。

ただ、ループはどちらかだけでいいと思います。

回答No.6

kkkkkm

> For Each cell In Range("A1:A" & lastRow)
> If cell.NumberFormat <> "@" Then
> For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

これだと、A1から最終行までを一巡しながら、セルの形式が文字列ではないセルがあるたびに、「A1から最終行まで一巡して形式を文字列に」を繰り返しています。
ループはどちらかだけでいいと思います。

お礼

コードを以下のように修正しました。

For Each cell In Range("A1:A" & lastRow)
If cell.NumberFormat <> "@" Then 'A列のセル書式設定が文字列で無い場合
cell.NumberFormatLocal = "@" 'セルの書式をテキストに変更
If Left(cell.Formula, 1) = "=" Then 'セルのフォーミュラが"="で始まる場合
cell.Value = Mid(cell.Formula, 2) 'セルの値をフォーミュラの2番目以降の文字列に変更
End If
cell.Value = cell.Formula
End If
Next cell

英文を日本語に翻訳するのにDeepLを利用したいのですが
無料版の場合１度に翻訳できる文字数が5000文字までで長文の場合（映画の英語字幕等）では
複数に区分けして処理する必要があります。

EXCELで複数のテキストファイルに分割までは成功しましたが
これを自動で複数ファイルを順番にDeppLに引き継いで翻訳させるのがこれからの課題となります。

調べれば参考になりそうなURLがそこそこ見つかりますが
https://qiita.com/KYUPHD/items/8edb740bcb9c59459c93

素人の私には、難易度が高く簡単ではありません。
もう少し調べて先が少し見えそうなら改めて相談させていただきます。

回答No.5

kkkkkm

現状のデータを文字列指定に直すとしたら、以下でできると思います。範囲に数式そのものはないものとします。

Sub test()
Dim i As Long

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Cells(i, 1).NumberFormatLocal = "@"
If Left(Cells(i, 1).Formula, 1) = "=" Then
Cells(i, 1).Value = Mid(Cells(i, 1).Formula, 2)
End If
Cells(i, 1).Value = Cells(i, 1).Formula
Next

End Sub

お礼

ありがとうございます。

コードを参考に以下のように改造してみました。

Sub CountCharacters()

Dim i As Long
Dim lastRow As Long
Dim cell As Range
Dim temp As Variant

lastRow = Cells(Rows.Count, 1).End(xlUp).Row

'A列のセル書式設定が文字列であるかどうか
For Each cell In Range("A1:A" & lastRow)
If cell.NumberFormat <> "@" Then
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
'セルの書式をテキストに変更
Cells(i, 1).NumberFormatLocal = "@"
'セルのフォーミュラが"="で始まる場合
If Left(Cells(i, 1).Formula, 1) = "=" Then
'セルの値をフォーミュラの2番目以降の文字列に変更
Cells(i, 1).Value = Mid(Cells(i, 1).Formula, 2)
End If
Cells(i, 1).Value = Cells(i, 1).Formula
Next
End If
Next cell

'1行の文字数カウント＞書き出し
For i = 1 To lastRow
Set cell = Cells(i, 1)
cell.Offset(0, 1).Value = Len(cell.Value)
Next i

'列入れ替え(2列目を１列目と入れ替え）
For i = 1 To lastRow
temp = Cells(i, 1).Value
Cells(i, 1).Value = Cells(i, 2).Value
Cells(i, 2).Value = temp
Next i

'先頭に空列を２つ挿入
'１行目に空行を１つ挿入(見出し行)
Columns("A:B").Insert Shift:=xlToRight
Rows("1:1").Insert Shift:=xlDown

'見出し行
Range("A1") = "塗分け"
Range("B1") = "総文字数"

End Sub

回答No.4

kkkkkm

> Excelが計算式と判断して　「=- Kind of the highlight of her day.」とイコール（＝）を先頭に付加してしまっています。

最初にセルの表示形式を「文字列」にしてからデータを入れるようにしてみてください。他にもありそうな、文字列と判断されないようなデータも、文字列として判断されると思います。

以下の部分ですが、cellってここでしか使われてないと思います
cellにせずにCells(i, 1)のままでいいのではないでしょうか。

For i = 1 To lastRow
Set cell = Cells(i, 1)
cell.Offset(0, 1).Value = Len(cell.Value)
Next i

1行の文字数カウント＞書き出し
と
'列入れ替え(2列目を１列目と入れ替え）
は一度のループで済ませられるような気もします。

もしくは、最初にA列の前に1列挿入(もしくは3列挿入、最後の2列もここで行う)して
1行の文字数カウント＞書き出し
を行ってもいいのではないでしょうか。

お礼

修正コードありがとうございます。

以下のコードでマイナスの場合「'」を付けて強制的に文字列にしようと思いましたが
A列にテキストを読み込んだ（コピペ）した時点で＃NAME？のエラーなので
マクロで修正する以前の問題だと気がつきました。

For Each cell In Range("A1:A" & lastRow)
If Left(cell.Value, 1) = "-" Then
cell.Value = "'" & cell.Value
End If
Next cell

現時点では、
テキストエディター（EmEditor）で最初の文字がマイナスなら削除する事で
事前に処理するぐらいしか思いついていません。

補足

>最初にセルの表示形式を「文字列」にしてからデータを入れるようにしてみてください。

そうでした。

セルの書式設定で処理できる事例でした。

悩み始めると修正が効かずにあらぬ方向に思考が進んでしまいました。

おかげさまで、無事テキストに分割できました。

回答No.3

imogasi

質問範囲外ですが、まず回答者はテストデータが必要。
（テストするには、データ例を作ることは、やらざるをえない。手数がかかるのですよ。）
C列の各行に適当数（８０以下ぐらい？）を入力。この情報も質問に書くべきです。
手抜きのための思い付きで、D列に=REPT("A",C1)　と言う関数を入れて下方向に式を複写。
そのデータ例
B,C,D列
8 AAAAAAAA
67 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
72 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
73 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
71 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
303 12 AAAAAAAAAAAA
51 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
53 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
71 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
84 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
322 63 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
ーーー
常套手段のFor Nextで各行処理をする。
標準モジュールに
Sub test01()
lrw = Range("C10000").End(xlUp).Row
'clrindx = Array(0, 6, 3, 5)
'MsgBox lrw
stotl = 0 'B列
mrw = 1 '直前の変化後行
j = 1 'Colorindex値
'ーーーー
For i = 1 To lrw
stotl = stotl + Cells(i, "C")
If stotl >= 300 Then '300行を超えると
MsgBox i
Cells(i, "B") = stotl 'B列に各累計値セット
Range("A" & mrw & ":A" & i).Interior.ColorIndex = j: j = j + 1 'セル範囲に色づけ
mrw = i + 1
stotl = 0
Else
End If
Next i
'ーーー
'最終行後処理
Cells(i - 1, "B") = stotl
Range("A" & mrw & ":A" & i - 1).Interior.ColorIndex = j
End Sub
を作る。
そして実行。結果は略。
ここまでが質問の前段階。
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
後は、A列の同一色の入った行をまとめて１テキストファイルとして、全体では、複数ファイルに書き出す。
上記コードに、下記を組み込むことも可能だが、上記終了後に改めて行う方式にする。
テスト時に、Msgbox 行は表示が「しつこい」ならば、データ行を少なくするか、すべて削除してください。本番では不要だろう。
標準モジュールに
Sub test02() 'テキストファイル書き出し
lrw = Range("C10000").End(xlUp).Row
MsgBox lrw
'--初期設定
stotl = 0 'B列について
mrw = 1 '直前の変化した行
j = 1 'ファイル名の番号の開始期数字
'ーーーー
For i = 1 To lrw
stotl = stotl + Cells(i, "C")
If stotl >= 300 Then '300行を超えると
MsgBox i
flnam = "testf" & j 'ファイル名は "textf" & j にすると仮定
MsgBox flnam
'---
Open "C:\Temp\" & flnam & ".txt" For Output As #1
For k = mrw To i
Print #1, Cells(k, "D").Value
MsgBox Cells(k, "D").Value
Next k
Close #1
stotl = 0
mrw = i + 1
j = j + 1 'ファイルンの名前番号部を＋１
Else
End If
Next i
'----行の終了後ーーーーー
'----最終分ファイルへ書き出し
flnam = "testf" & j 'ファイル名は 続きの"textf" & j
MsgBox flnam
Open "C:\Temp\" & flnam & ".txt" For Output As #1
For k = mrw To i - 1
Print #1, Cells(k, "D").Value
MsgBox Cells(k, "D").Value
Next k
Close #1
End Sub
テストデータとテスト回数は十分でないの、後はよろしく。
やって見ただけ（説明文の用意など）数時間必要だった）で、自分にとって新しいものは無いやり方となった。

回答No.2

kkkkkm

No.1の追加です。

C列数値（D列の文字数）もVBAで出すのでしたら

最終行をD列から

lastRow = Cells(Rows.Count, "D").End(xlUp).Row

2行目から

For i = 2 To lastRow
Cells(i, "C").Value = Len(Cells(i, "D").Value) '←追加
sum = sum + Cells(i, "C").Value
If sum > 300 Then

に変更してください。

回答No.1

kkkkkm

以下で試してみてください。

Sub SumIfOver300()
Dim lastRow As Long
Dim sum As Long
Dim i As Long
Dim FRow As Long
Dim FCount As Long
Dim mColor As String

lastRow = Cells(Rows.Count, "C").End(xlUp).Row
sum = 0
FRow = 2
FCount = 1
mColor = "red"

For i = 1 To lastRow
sum = sum + Cells(i, "C").Value
If sum > 300 Then
Cells(i, "B").Value = sum
mColor = mColorSet(mColor, FRow, i)
Call mTxtFile(FCount, FRow, i)
FCount = FCount + 1
FRow = i + 1
sum = 0
End If
Next i
If FRow <= lastRow Then
mColor = mColorSet(mColor, FRow, lastRow)
Call mTxtFile(FCount, FRow, lastRow)
End If
End Sub

Function mColorSet(ByVal mColor As String, ByVal FRow As Long, ByVal i As Long) As String
If mColor = "red" Then
Cells(FRow, "A").Resize(i - FRow + 1, 1).Interior.Color = vbGreen
mColorSet = "green"
Else
Cells(FRow, "A").Resize(i - FRow + 1, 1).Interior.Color = vbRed
mColorSet = "red"
End If
End Function

Function mTxtFile(ByVal FCount As Long, ByVal FRow As Long, ByVal ERow As Long)
Dim FName As String
Dim j As Long

FName = Format(FCount, "000_text.txt")
Open "C:\OK\" & FName For Output As #1
For j = FRow To ERow
Print #1, Cells(j, "D").Value
Next
Close #1
End Function

お礼

kkkkkmさん、毎回教えていただきありがとうございます。

おしえていただいたコードの色を２つのグレー（薄い、濃い）に塗分けるように変更してうまく処理できるのを確認しました。
総数300文字はサンプルなので実例の4900に変更して実際のテキスト文字列をターゲットにして
添付画像のような形式に変更するためテキスト文字列をA列に配置してマクロ（CountCharctors）を起動させてみました。

途中までは変換されましたが、以下コードで「形が一致しません」がでました。

cell.Offset(0, 1).Value = Len(cell.Value)

チェックすると該当箇所はセル表示が＃NAME？と表示されています。

実際の文字列は、-（マイナス）で始まる　「- Kind of the highlight of her day.」なので
Excelが計算式と判断して　「=- Kind of the highlight of her day.」とイコール（＝）を先頭に付加してしまっています。

このため、単純なテキストもじと判断されずにエラーが表示されるのだと思います。

これを防ぐには、どうしたらいいでしょうか　？

（実例では、他にも文字列として判断されない事例が出てくる可能性がありそうです。）

Sub CountCharacters()

Dim i As Long
Dim lastRow As Long
Dim cell As Range
Dim temp As Variant

lastRow = Cells(Rows.Count, 1).End(xlUp).Row

'1行の文字数カウント＞書き出し
For i = 1 To lastRow
Set cell = Cells(i, 1)
cell.Offset(0, 1).Value = Len(cell.Value)
Next i

'列入れ替え(2列目を１列目と入れ替え）
For i = 1 To lastRow
temp = Cells(i, 1).Value
Cells(i, 1).Value = Cells(i, 2).Value
Cells(i, 2).Value = temp
Next i

'先頭に空列を２つ挿入
'１行目に空行を１つ挿入(見出し行)
Columns("A:B").Insert Shift:=xlToRight
Rows("1:1").Insert Shift:=xlDown

'見出し行
Range("A1") = "塗分け"
Range("B1") = "総文字数"

End Sub