エクセル マクロで指定する行と列を削除後、改行を置換してCSV保存する方法

お世話になります。

現在、testフォルダに複数の定型エクセルファイル（シートは各1つですが項目は同じでデータ量はそれぞれ異なります。）があり
上部2行と左1列を削除して、全セル内の　改行　を半角スペース2つに置換してCSV保存したいと思います。

改行を半角スペース2つに置換すること　以外のところまでは
以下マクロで、ご教示いただいたのですが
新たな操作として追加したい「改行（置換）」のところでどのようにするとよいか悩んでいます。

-----ここから------
Option Explicit
Dim myPath As String
Sub Main()
'パスの場所
myPath = "C:\Users\Users\Desktop\test\"　 'フォルダまでのパス
Dim wb As Workbook
If Right(myPath, 1) <> "\" Then myPath = myPath & "\"
Dim FName As String
Dim i As Long, j As Long
Dim myArray As Variant
Application.ScreenUpdating = False

ReDim myArray(2000)
i = 0
FName = Dir(myPath & "*.xls", vbNormal)
Do While FName <> ""
If FName <> "." And FName <> ".." Then
If (GetAttr(myPath & FName) And vbNormal) = vbNormal Then
myArray(i) = FName
i = i + 1
End If
End If
FName = Dir
Loop
ReDim Preserve myArray(i - 1)
Call MakingCSVFiles(myArray)
Application.ScreenUpdating = True

MsgBox "Finish!"
End Sub
Sub MakingCSVFiles(myArray)
Dim sh As Worksheet
Dim rng As Range
Dim buf As Variant
Dim fileName As String, FName As String
Dim ext As String: ext = ".csv" '拡張子
Dim j As Long, w As Variant
Dim wb As Workbook
Dim BaseName As String
For Each w In myArray
'ステータスバーに処理中のファイル名を出す。
Application.StatusBar = w
If w <> ThisWorkbook.Name And StrConv(Right(w, 1), vbLowerCase) <> "b" Then
Set wb = Workbooks.Open(myPath & Trim(w))
ActiveSheet.Copy
Set sh = ActiveSheet
Set rng = sh.UsedRange
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
If Application.CountA(Cells) = 0 Then
'開いた場所にデータがない場合
sh.Parent.Close False
wb.Close False
GoTo Endline
End If
j = 0
BaseName = Mid(w, 1, InStr(w, ".") - 1)

Do While Dir(myPath & BaseName & ext) <> ""
If InStrRev(BaseName, "_") > 0 Then
BaseName = Mid$(BaseName, 1, InStrRev(BaseName, "_") - 1)
End If
j = j + 1
BaseName = BaseName & "_" & CStr(j)
Loop
ActiveWorkbook.SaveAs myPath & BaseName & ext, xlCSV
ActiveWorkbook.Close False
On Error Resume Next
wb.Close False
On Error GoTo 0
End If
Endline:
Next w
Application.StatusBar = ""
End Sub
------//ここまで------



追加したい「改行コードの置換」操作のマクロの記録結果は、以下でした。

Sub KaigyouDelate()
'改行を取る
Cells.Select
Selection.Replace What:="" & Chr(10) & "", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveWorkbook.Save
End Sub


上記--ここから----// ここまで------のマクロに
この操作「改行コードを半角スペース2つに置換」を追加する方法をご教示いただければ幸いです。

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2016/11/20 20:37

こんばんは。

セル内の改行コードがあるというと、確か、CSVに出力すると、途中で改行されたり、変な具合になりますね。そういうのを直すということですね。

--セル内--置換後---
X　　　　|X　　abc
abc
-----
というスタイルになることですね。

Sub KaigyouDelate()
ちょっと、この内容では、厳しいと思います。無理ではありませんが、時間が掛かります。それと、"" & Chr(10) & ""　長さ0の文字列("")を置く必要があるのか、私は、良く分かりませんが、今回、それはナシにしました。

Cells.Select をすると、ものすごく遅くなってしまいますので、
そういう場合は、ActiveSheet.UsedRange などを使います。

私の書いたコードとは若干違うようですが、その部分はそのままにし、保険を置いておきます。今回は、少ないファイルで調べましたので、どのようなことが起こるかは、まだ未知です。十分に調べてみてください。今回のセル内の直し方は、あまり選択肢はないようです。出力後は直せません。

Sub MakingCSVFiles(myArray)の中で、ステータスバーというところから、2行目です。

　　If w <> ThisWorkbook.Name And StrConv(Right(w, 1), vbLowerCase) <> "b" Then
　　　Set wb = Workbooks.Open(myPath & Trim(w))
　　　ActiveSheet.Copy
　　　Set sh = ActiveSheet
　　　Set rng = sh.UsedRange
　　　sh.Rows("1:2").Delete Shift:=xlUp　'ここを加筆
　　　sh.Columns("A:A").Delete Shift:=xlToLeft　'〃
　　　If Application.CountA(Cells) = 0 Then
　　　　'開いた場所にデータがない場合
　　　　sh.Parent.Close False
　　　　wb.Close False
　　　　GoTo Endline
　　　Else
　　　　Dim c As Range
　　　　Dim FirstAddress As String
　　　　With sh.UsedRange
　　　　　Set c = .Find(What:=vbLf, LookIn:=xlFormulas, LookAt:=xlPart)
　　　　　If Not c Is Nothing Then
　　　　　　FirstAddress = c.Address
　　　　　　Do
　　　　　　　c.Value = Replace(c.Value, vbLf, "　")
　　　　　　　Set c = .FindNext(c)
　　　　　　　If c Is Nothing Then Exit Do
　　　　　　　If c.Address = FirstAddress Then Exit Do　　'使っていないはず
　　　　　　Loop
　　　　　End If
　　　　End With
　　　End If
'（j = 0 の手前まで)
------------------------

この回答へのお礼

ありがとうございました！！
素晴らしい結果となりました。

当該箇所を修正したら　うまく稼働しました。　<(_ _)>

心より御礼申し上げます。

お礼日時：2016/11/20 21:11