(VBA) 不要な複数改行の削除

質問

この質問は、
　以下の質問の追加（不随）となります。

テキストファイル中のカタカナ文字をスペースに変換
https://okwave.jp/qa/q9912531.html

>変換元のテキストと
>期待する返還後のシートの内容を示してください。

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

sheet1にターゲットのテキストファイルが読み込まれています
sheet2に半角カタカナ文字をが削除された返還後のテキストファイル

　上側が変換元のテキスト（カタカナ文字削除後）　緑色の枠の中
　下側が理想とする返還後のシート内容です。　　　赤色の枠の中
(手動で不要な複数改行を削除して作成）

下側のように変換されてほしいのに
　上側のように不必要な改行が削除されていません。

回答No.6

kkkkkm · ベストアンサー

画像の赤枠の所は記号だと思います。

EmEditorで文字コードを表示するには

表示したい文字のすぐ左側にカーソルを置いて、[表示] メニューの [文字コード値] を選択します。

のようです。

現状はファイル書き出しにしていますので、セルにだけ書き出したい場合は、コメント部分を有効にしてファイル書き出し部分をコメントにしてください。

元ファイル

あｱんﾝぱ　　ﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ
ｱｱｱｱｱｱ
____________________←もとから半角スぺース

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ
あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

ｱｱｱｱｱｱ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

を

新ファイル

あ ん ぱ　　 ん ま ん が あ る く よ

あ ん ぱ ん ま ん が あ る く よ

あ ん ぱ ん ま ん が あ る く よ

あ ん ぱ ん ま ん が あ る く よ
あ ん ぱ ん ま ん が あ る く よ

あ ん ぱ ん ま ん が あ る く よ

にします。

Sub Test()
Dim j As Long, n As Long, cnt As Long
Dim SelectFile As Variant
Dim buf As String, buf2 As String, tmp As String
Dim mCha As String, NewFileName As String
Dim mPath As String
Dim FileNum As Integer

'ChDir "C:\Users\NuNu\Desktop"
SelectFile = Application.GetOpenFilename("txtファイル(*.txt),*.txt")

If VarType(SelectFile) = vbBoolean Then
MsgBox "キャンセルされました"
Else
'MsgBox SelectFile & " が選択されました"
Open SelectFile For Input As #1
End If
n = 1
Do Until EOF(1)
Line Input #1, buf
If Len(buf) > 1 Then
For j = 1 To Len(buf)
mCha = Mid(buf, j, 1)
If mCha Like "[ｦ-ﾟ ]" Then
tmp = tmp & " "
Else
tmp = tmp & mCha
End If
Next
If Len(Replace(StrConv(tmp, vbNarrow), " ", "")) > 1 Then
cnt = 0
' Cells(n, "A").Value = tmp
' n = n + 1
buf2 = buf2 & tmp & vbCrLf

End If
tmp = ""
Else
If cnt = 0 Then
' Cells(n, "A").Value = buf
' n = n + 1
buf2 = buf2 & vbCrLf
End If
cnt = cnt + 1
End If
Loop
Close #1

NewFileName = "New" & Dir(SelectFile)
mPath = ThisWorkbook.Path & "\" & NewFileName
FileNum = FreeFile
Open mPath For Output As #FileNum
Print #FileNum, buf2
Close #FileNum
End Sub

お礼

kkkkkmさん、修正されたコードをありがとうございます。

普段、テキストファイルは「メモ帳」を利用する事が多く
Em Editorは、テキストファイルの比較に利用する程度で
　文字コードをチェックする機能がある事を知りませんでした。
（教えていただきありがとうございます。）

半角スペース　：　U+0020　/　shiftJIS　0ｘ20
改行　　　　　：　U+000DU+000A / shiftJIS 0x0D 0x0A

修正コードで思いどうりに不要な連続する
　改行もどき（連続する複数の半角スペース＋改行）を
　一つの改行だけにできました。

回答No.9

kkkkkm

> n=1の事でしょうか？
> １が何を示すかがよく分かりません。？

またまた書き方が間違いでした。>は引用符と認識されることを考えていませんでした。

文字数を数えている所で

Len(buf) > 1

Len(Replace(StrConv(tmp, vbNarrow), " ", "")) > 1

のところの　> 1 が　> 0 でした。
1文字以上と考えていて、つい「1」としてしまってました。

お礼

こちらこそ引用符と不等号の判断を間違っていました。

修正依頼の（>1の件）2か所を修正しました。

最後までお付き合い願いありがとうございました。
おかげさまで解決しました。

回答No.8

kkkkkm

> Em Editorは、テキストファイルの比較に利用する程度で

有料のやつですよね…なんかもったいない感じですね。

あと

> 1

が2か所あるのは

> 0

でした。

補足

>有料のやつですよね…なんかもったいない感じですね。

　　　emeditorのテキストファイルの比較が優秀なので時々利用する程度で
　　　　確かにもったいないですね。

>あと

> 1

>が2か所あるのは

> 0

>でした。

n=1の事でしょうか？
１が何を示すかがよく分かりません。？

回答No.7

HohoPapa

半角スペースと改行の行を改行だけに変更するコードを加えました。

Option Explicit

Sub Sample1()

Dim buf As String
Dim Target
Dim tmp1
Dim wkText As String
Dim i As Long

Target = _
Application.GetOpenFilename(Filefilter:="ansiのテキストファイル,*.txt")
If Target = False Then Exit Sub

With CreateObject("ADODB.Stream")
.Charset = "Shift_jis"
.Open
.LoadFromFile Target
buf = .ReadText
buf = ChgKana(buf)

'半角と改行だけの行を改行だけの行に変更
wkText = ""
tmp1 = Split(buf, vbCrLf)
For i = 0 To UBound(tmp1)
If Trim(tmp1(i)) = "" Then
wkText = wkText & vbCrLf
Else
wkText = wkText & tmp1(i) & vbCrLf
End If
Next i

'改行が３つ連続していたら、改行を２つに変更
Do
If InStr(wkText, vbCrLf & vbCrLf & vbCrLf) = 0 Then Exit Do
wkText = Replace(wkText, vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
Loop

.Close
.Open
.writetext wkText
.savetofile Target, 2
.Close
End With

End Sub

Function ChgKana(text As String) As String

Dim MyLen As Long
Dim wkStr As String
Dim i As Long
MyLen = Len(text)

wkStr = ""
For i = 1 To MyLen
If ( _
(Asc(Mid(text, i, 1)) >= &HA6) And _
(Asc(Mid(text, i, 1)) <= &HDF)) Then
wkStr = wkStr & " "
Else
wkStr = wkStr & Mid(text, i, 1)
End If
Next i
ChgKana = wkStr

End Function

お礼

HohoPapaさん、修正されたコードありがとうございます。

不要な改行もどきの行が削除されて
　テキストファイルが更新されるのを確認しました。

前の質問から引き続き参加いただき感謝いたします。

やりたいことが出来たので終了にしますね。

回答No.5

kkkkkm

ループの前という書き方が間違ってましたDoの前でした。

複数ある改行を一つだけにしたいという事だと思いますので
現状はファイル書き出しにしていますので、セルにだけ書き出したい場合は、コメント部分を有効にしてファイル書き出し部分をコメントにしてください。

buf2 = buf2 & vbCrLf
の2か所と
最後の方の
NewFileName = "New" & Dir(SelectFile)
mPath = ThisWorkbook.Path & "\" & NewFileName
FileNum = FreeFile
Open mPath For Output As #FileNum
Print #FileNum, buf2
Close #FileNum
部分です。

元ファイル
↓
あｱんﾝぱ　　ﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ
あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

が

新ファイル
↓
あ ん ぱ　　 ん ま ん が あ る く よ

あ ん ぱ ん ま ん が あ る く よ

あ ん ぱ ん ま ん が あ る く よ

あ ん ぱ ん ま ん が あ る く よ
あ ん ぱ ん ま ん が あ る く よ

あ ん ぱ ん ま ん が あ る く よ

になります。

Sub Test()
Dim j As Long, n As Long, cnt As Long
Dim SelectFile As Variant
Dim buf As String, buf2 As String
Dim mCha As String, NewFileName As String
Dim mPath As String
Dim FileNum As Integer

'ChDir "C:\Users\NuNu\Desktop"
SelectFile = Application.GetOpenFilename("txtファイル(*.txt),*.txt")

If VarType(SelectFile) = vbBoolean Then
MsgBox "キャンセルされました"
Else
'MsgBox SelectFile & " が選択されました"
Open SelectFile For Input As #1
End If
n = 1
Do Until EOF(1)
Line Input #1, buf
If Len(buf) > 1 Then
For j = 1 To Len(buf)
mCha = Mid(buf, j, 1)
If mCha Like "[ｦ-ﾟ ]" Then
buf2 = buf2 & " "
Else
buf2 = buf2 & mCha
End If
Next
cnt = 0
' Cells(n, "A").Value = buf2
' n = n + 1
' buf2 = ""
buf2 = buf2 & vbCrLf 'ここ
Else
If cnt = 0 Then
' Cells(n, "A").Value = buf
' n = n + 1
buf2 = buf2 & vbCrLf 'ここ
End If
cnt = cnt + 1
End If
Loop
Close #1

NewFileName = "New" & Dir(SelectFile)
mPath = ThisWorkbook.Path & "\" & NewFileName
FileNum = FreeFile
Open mPath For Output As #FileNum
Print #FileNum, buf2
Close #FileNum
End Sub

補足

HohoPapaさん、kkkkkmさん　回答感謝します。

HohoPapaさんに指摘されて気が付きました。

提示したサンプル画像のテキスト情報ですが
空行に見える行は改行だけではありませんでした。

指摘されたように半角スペースの連続と最後に改行でした。

（半角のカタカナを半角のスペースに変換したので
　　結果は当然なのですが。。。。）

私のケアレスミスで質問の前提が崩れてしまい
横道にそれた回答を頂き無駄になった事をお詫び申し上げます。

以下の参考画像は、
　ファイルに書き出した変換後のテキストファイルを
　テキストエディター(Em Editor)で表示した画像です。

　改行コード（↓）の左側に
　　ずらっと連続する複数の半角スペースコード（）が配置されています。

https://imgur.com/ivgTsL1

　　＊半角コードが赤枠で示したモノかどうかは良くわかりませんが
　　　形は同じなので付加しただけで参考程度と思ってください。

コードが全く違う方向になると思いますが宜しくお願いします。

回答No.4

HohoPapa

空行が2行以上連続していたら、これを空行1行に変換する、
つまり、改行が３つ以上連続していたら、２つに置き換えるということでいいでしょうか。

であれば、また、
過日当方がポストしたコードを手直ししたものでよければ、
以下です。

なお、
サンプル提示された情報（テキスト）が画像なので
よくわかりませんが、
空行に見える行は改行だけなんですよね？
それとも、半角、あるいは全角のスペースが含まれますか？

Option Explicit

Sub Sample1()

　Dim buf As String
　Dim Target

　Target = _
　　Application.GetOpenFilename(Filefilter:="ansiのテキストファイル,*.txt")
　If Target = False Then Exit Sub

　With CreateObject("ADODB.Stream")
　　.Charset = "Shift_jis"
　　.Open
　　.LoadFromFile Target
　　buf = .ReadText

　　'改行が３つ連続していたら、改行を２つに変更
　　Do
　　　If InStr(buf, vbCrLf & vbCrLf & vbCrLf) = 0 Then Exit Do
　　　buf = Replace(buf, vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
　　Loop

　　.Close
　　.Open
　　.writetext ChgKana(buf)
　　.savetofile Target, 2
　　.Close
　End With

End Sub

Function ChgKana(text As String) As String

　Dim MyLen As Long
　Dim wkStr As String
　Dim i As Long
　MyLen = Len(text)

　wkStr = ""
　For i = 1 To MyLen
　　If ( _
　　　 (Asc(Mid(text, i, 1)) >= &HA6) And _
　　　 (Asc(Mid(text, i, 1)) <= &HDF)) Then
　　　wkStr = wkStr & " "
　　Else
　　　wkStr = wkStr & Mid(text, i, 1)
　　End If
　Next i
　ChgKana = wkStr

End Function

補足

HohoPapaさん、kkkkkmさん　回答感謝します。

HohoPapaさんに指摘されて気が付きました。

提示したサンプル画像のテキスト情報ですが
空行に見える行は改行だけではありませんでした。

指摘されたように半角スペースの連続と最後に改行でした。

（半角のカタカナを半角のスペースに変換したので
　　結果は当然なのですが。。。。）

私のケアレスミスで質問の前提が崩れてしまい
横道にそれた回答を頂き無駄になった事をお詫び申し上げます。

以下の参考画像は、
　ファイルに書き出した変換後のテキストファイルを
　テキストエディター(Em Editor)で表示した画像です。

　改行コード（↓）の左側に
　　ずらっと連続する複数の半角スペースコード（）が配置されています。

https://imgur.com/ivgTsL1

　　＊半角コードが赤枠で示したモノかどうかは良くわかりませんが
　　　形は同じなので付加しただけで参考程度と思ってください。

コードが全く違う方向になると思いますが宜しくお願いします。

----------------------
>空行が2行以上連続していたら、これを空行1行に変換する、
>つまり、改行が３つ以上連続していたら、２つに置き換えるということでいいでしょうか。

連続した改行もどき（連続する複数の半角スペース＋改行）を
　一つの改行だけにしたいです。

難しい場合は、3個続いたら１つに置き換えるでも構いません。

回答No.3

kkkkkm

書き忘れてました
No1は、元の質問のNo3さんの回答をもとにしたものです。

回答No.2

kkkkkm

No1の追加です。

ファイル出力しなくて1行ごと1セルに入れたい場合には

buf2 = buf2 & vbCrLf
を
ループの前にでもn=1入れて
Cells(n, "A").Value = buf2
n = n + 1
buf2 = ""

にしてください。

お礼

kkkkkmさん、半角カタカナ文字の削除（スペースへ変換）の別回答ありがとうございます。

元ファイル（ターゲット）を残して
　新規に別ファイル（New＋ターゲット）に書き出すので安心感があります。

>No1の追加です。
>ファイル出力しなくて1行ごと1セルに入れたい場合には

下記のようにしましたがシートに出力されません。
どこが間違っていますか　？

Do Until EOF(1)
Line Input #1, buf
If Len(buf) > 1 Then
For j = 1 To Len(buf)
mCha = Mid(buf, j, 1)
If mCha Like "[ｦ-ﾟ ]" Then
buf2 = buf2 & " "
Else
buf2 = buf2 & mCha
End If
Next
'buf2 = buf2 & vbCrLf
Cells(n, "A").Value = buf2
n = n + 1
buf2 = ""
End If
n = 1
Loop
Close #1

----------------------
又、今回の質問である無駄な改行を削除する件に付いて
　教えていただければ幸いです。

回答No.1

kkkkkm

もとの
テキストファイル中のカタカナ文字をスペースに変換
ということでテキストファイルに書き出す(もしくはひとつのセルに書き出す)のでしたら元のファイル名にNewを頭につけて書き出します。

あｱんﾝぱ　　ﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

あｱんﾝぱﾊﾟんﾝまﾏんﾝがｶﾞあｱるﾙくｸよ

のテキストファイルを

あ ん ぱ　　 ん ま ん が あ る く よ
あ ん ぱ ん ま ん が あ る く よ
あ ん ぱ ん ま ん が あ る く よ

のテキストファイルにします。

Sub Test()
Dim j As Long
Dim SelectFile As Variant
Dim buf As String, buf2 As String
Dim mCha As String, NewFileName As String
Dim mPath As String
Dim FileNum As Integer

'ChDir "C:\Users\NuNu\Desktop"
SelectFile = Application.GetOpenFilename("txtファイル(*.txt),*.txt")

If VarType(SelectFile) = vbBoolean Then
MsgBox "キャンセルされました"
Else
'MsgBox SelectFile & " が選択されました"
Open SelectFile For Input As #1
End If

Do Until EOF(1)
Line Input #1, buf
If Len(buf) > 1 Then
For j = 1 To Len(buf)
mCha = Mid(buf, j, 1)
If mCha Like "[ｦ-ﾟ ]" Then
buf2 = buf2 & " "
Else
buf2 = buf2 & mCha
End If
Next
buf2 = buf2 & vbCrLf
End If
Loop
Close #1

NewFileName = "New" & Dir(SelectFile)
mPath = ThisWorkbook.Path & "\" & NewFileName
FileNum = FreeFile
Open mPath For Output As #FileNum
Print #FileNum, buf2
Close #FileNum
'ひとつのセルに出したい場合はこちらで
'Range("A1").Value = buf2
End Sub