テキストファイルを分割したいんです。

質問

すごい長文のテキストファイルがあるんですけど、これを１０００文字に分割して複数のファイルを作りたいんです。　べつに携帯にメールを送る為じゃなくて、ただ分割したいだけなんですけど、そんなソフトってあるんでしょうか・・・？

回答No.14

Wendy02

marbinさん、こんにちは。
Wendy02です。

＞※私のコードを実際に試したら、一つのテキストファイルが
＞1000文字を超える超えることもありました。？？です。

すみません、言葉が足らなかったようです。

Print #2, naiyou;
Close #2
naiyou = ""
MyLen = 0
naiyou = dat
End If

この部分で、最後のdatは、nayouに移し変えされていますから、2度目からは、1,000文字を越えますが、論理的に、 datが確保されていない最初の時だけ、文字数が足りませんね。だから、1回目だけ、datを別に確保してあげればよいかもしれません。

なお、私のコードの場合は、改行コードを、1文字と数えていますから、多少、可読される文字数は足りません。

回答No.13

marbin

皆さん、こんにちは。
Wendy02さん、ご指摘ありがとうございます。
ご指摘の内容、勉強不足でわからないところがありますの
で勉強してみます。

※私のコードを実際に試したら、一つのテキストファイルが
1000文字を超える超えることもありました。？？です。

外部データの取り込み、でエクセルに取込んだほうがいいの
かもしれません。

回答No.12

Wendy02

marbin様　こんばんは。

質問者さんが見ていないような気がしますので、今、No.11 の最新バージョンを、私のほうで見させていただきました。

ちょっと気になったことですが、ループして、
If MyLen + Len(dat) > 1001 Then

で、1000を越えると、

Open Newtxtmei For Output As #2
Print #2, naiyou;

この部分に入っていくわけですが、たぶん、新たに加えた Dat 分が加わっていないように思います。つまり、Len(dat) が、300,400,400 と数を数えて、3度目で、700 + 400 >1001 になるのですが、3度目の400 分が、Print の時のnaiyou に加わっていないように思います。

そうすると、出力された文字数が足りなくなってしまうような気がします。
datが、CrLF までの文字列ですから、いずれにしても、多い少ないはできてしまいます。

私のうろ覚えでは、Line ～ Input 方式は、Buffer に全部溜め込んで、切り分けるというようなことをしたと思います。もちろん、Buffer は、String 型にしておくわけですね。どのぐらいの容量があるのは、あまり覚えがないのですが、数メガだったと思います。その大きさの根拠は、インターネットのWebページのBufferは、結構あるような気がしますが、Excel VBAのString型変数で、まかなえます。

聞くところによると、Scripting.FileSystemObjectのTextStream の ReadAll だと、コケるということを聞いたことがあります。単なる噂なのか知りませんが、試してみてことがありません。

せっかく、何度も精力的に書かれたわけで、そのままになってしまうのは惜しいので、書かせていただきました。もし、お気を悪くされたら、お見捨てください。

なお、個人的なことですが、私は、Desktop ではなくて、
　SpecialFolders("MyDocuments")
にしました。

回答No.11

marbin

またまた修正版です。

Sub txtbunkatu()
Dim txtmei As String
Dim Newol As String
Dim Newtxtmei As String
Dim i As Long
Dim j As Long
Dim MyLen As Long
Dim naiyou As String
txtmei = Application.GetOpenFilename(Title:="テキストファイル")
If txtmei = "False" Then Exit Sub
newfol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & _
Format(Now, "yymmdd_hhmmss")
MkDir (newfol)
Open txtmei For Input As #1
Do Until EOF(1)
Line Input #1, dat
i = i + 1
If MyLen + Len(dat) > 1001 Then
j = j + 1
Newtxtmei = newfol & "\" & "Newtxt" & j & ".txt"
If Dir(Newtxtmei) <> "" Then
MsgBox "既に同名のファイルが存在します。"
Exit Sub
Else
Open Newtxtmei For Output As #2
Print #2, naiyou;
Close #2
naiyou = ""
MyLen = 0
naiyou = dat
End If
Else
MyLen = MyLen + Len(dat)
naiyou = naiyou & vbCrLf & dat
End If
Loop
Close #1
If naiyou <> "" Then
Newtxtmei = newfol & "\" & "Newtxt" & j + 1 & ".txt"
Open Newtxtmei For Output As #1
Print #1, naiyou;
Close #1
naiyou = ""
MyLen = 0
End If
End Sub

回答No.10

marbin

う～、すみません。何度も・・・。

最後のファイルが書き出されませんね。
もう一度見直します・・・。

回答No.9

marbin

#2です。エラーの原因が分かりました。
↓のように訂正すれば大丈夫だと思います。

Input #1, dat
↓
Line Input #1, dat

回答No.8

Wendy02

こんばんは。

私もちょっと考えてみました。
同じフォルダに、枝番が付きます。ただし、9999 を越える分には、途中で止まってしまいます。通常、この種のものは、Binary 処理か、ライン処理をするような気がします。この手のものは、ほとんど手がけたことがありませんから、あまり私のは自信がありません。

'なるべく標準モジュールに登録してください。
'-------------------------------------------
Sub TextSpliting()
Dim FileName As String
Dim FileBaseName As String
Dim objFS As Object
Dim objText As Object
Dim myText As String
Dim i As Long
Dim myFno As Integer
Const SPLIT_WORD_COUNT As Integer = 1000

　　FileName = Application.GetOpenFilename("Textファイルl(*.txt),*.txt")
　　 If FileName = "False" Then Exit Sub

　　FileBaseName = Mid$(FileName, 1, InStrRev(FileName, ".") - 1)
　　Set objFS = CreateObject("Scripting.FileSystemObject")
　　Set objText = objFS.OpenTextFile(FileName)
　　i = 1
　　Do While objText.AtEndOfLine <> True
　　　 myText = objText.Read(SPLIT_WORD_COUNT)
　　　 myFno = FreeFile()
　　　 Do
　　　　 Open FileBaseName & " _" & Format$(i, "0000") & ".txt" For Output As #myFno
　　　　　 Print #myFno, myText
　　　　 Close #myFno
　　　　 i = i + 1
　　　 If i > 9999 Then Exit Do
　　　 Loop Until Dir(FileBaseName & " _" & Format$(i, "0000") & ".txt") = ""
　　Loop
　 objText.Close
　 Set objText = Nothing
　 Set objFS = Nothing
End Sub

回答No.7

marbin

一応修正版は出来ました。
しかし、時刻データがおかしくなるようです。
原因不明です。すみません。

Sub txtbunkatu()
Dim txtmei As String
Dim Newol As String
Dim Newtxtmei As String
Dim i As Long
Dim j As Long
Dim MyLen As Long
Dim naiyou As String
txtmei = Application.GetOpenFilename(Title:="テキストファイル")
If txtmei = "False" Then Exit Sub
newfol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & _
Format(Now, "yymmdd_hhmmss")
MkDir (newfol)
Open txtmei For Input As #1
Do Until EOF(1)
Input #1, dat
i = i + 1
If MyLen + Len(dat) > 1001 Then
j = j + 1
Newtxtmei = newfol & "\" & "Newtxt" & j & ".txt"
If Dir(Newtxtmei) <> "" Then
MsgBox "既に同名のファイルが存在します。"
Exit Sub
Else
Open Newtxtmei For Output As #2
Print #2, naiyou;
Close #2
naiyou = ""
MyLen = 0
naiyou = dat
End If
Else
MyLen = MyLen + Len(dat)
naiyou = naiyou & vbCrLf & dat
End If
Loop
Close #1
End Sub

回答No.6

marbin

#2です。
私の提示したコードにはバグがありました。
1000文字目が含まれた行が抜け落ちると思います。
修正版が出来たらアップします。

回答No.5

marbin

フォルダ作成バージョンが出来たのでアップします。

Sub txtbunkatu()
Dim txtmei As String
Dim Newol As String
Dim Newtxtmei As String
Dim i As Long
Dim j As Long
Dim MyLen As Long
Dim naiyou As String
txtmei = Application.GetOpenFilename(Title:="テキストファイル")
If txtmei = "False" Then Exit Sub
newfol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & _
Format(Now, "yymmdd_hhmmss")
MkDir (newfol)
Open txtmei For Input As #1
Do Until EOF(1)
Input #1, dat
i = i + 1
If MyLen + Len(dat) > 1001 Then
j = j + 1
Newtxtmei = newfol & "\" & "Newtxt" & j & ".txt"
If Dir(Newtxtmei) <> "" Then
MsgBox "既に同名のファイルが存在します。"
Exit Sub
Else
Open Newtxtmei For Output As #2
Print #2, naiyou;
Close #2
naiyou = ""
MyLen = 0
End If
Else
MyLen = MyLen + Len(dat)
naiyou = naiyou & vbCrLf & dat
End If
Loop
Close #1
End Sub