Excelvba_Loopが望まぬところにかかる2

質問

ループは指定したパスのフォルダのファイルにかけているつもりなのですが
マクロ処理は,、最初に↑から拾った１つ目のファイルがCドライブに保存され
そのファイルに対してマクロ処理のループがかかり
Ｃドライブに１つ目の保存ファイルが増えていく一方な現象。

どう解決したらよいでしょうか？

*******
Sub NEM_Macroループ ( )
'
' フォント変更、記号変換、テキストボックス、全シート
'
Dim myFile As String
Dim myPath As String
Dim myBook As Workbook
Dim mySheet As Worksheet
Dim myRange As Range

Application.ScreenUpdating = False

'Cドライブに修正後というフォルダを作成します。
MkDir "C:\Users\XXXXXX\Desktop\NEM_macro\修正後"

'フォントを変更するファイルが保存されているフォルダのパスを指定します。
myPath = "\\Jp\Work\NEM"

'指定したフォルダ内の全てのExcelファイルに対してループを実行します。
myFile = Dir(myPath & "\*.xlsx")
Do While myFile <> ""

'各ファイルを開きます。
Set myBook = Workbooks.Open(myPath & "\" & myFile)

'全てのワークシートに対してループを実行します。
For Each mySheet In myBook.Sheets

'シート内の全てのセルに対してループを実行します。
Set myRange = mySheet.UsedRange

***処理マクロ（フォント変更など）***

Dim 年月
Dim ThisName, NewName
Dim MojiCoA As Integer, MojiCoB As Integer

'Format,Year,Month関数を利用します
年月 = Year(Date) & "_" & Month(Date)

'拡張子なしのファイル名を取得します
MojiCoA = InStrRev(ActiveWorkbook.Name, ".")

ThisName = Left(ActiveWorkbook.Name, MojiCoA - 1)

'ファイル名を変数へ設定します
NewName = "C:\Users\XXXXXX\Desktop\NEM_macro\"修正後" & "\" & ThisName & 年月 & ".xlsx"

'作成したWorkbookを名前を付けて、移動先フォルダに保存します
ActiveWorkbook.SaveAs Filename:=NewName

'次のファイルに移動します。

Next
myFile = Dir()

Loop

End Sub

回答No.1

kkkkkm · ベストアンサー

Nextの場所が違うと思いますので、現状ではシートの数だけ同じファイルを保存しようとします。

For Each mySheet In myBook.Sheets

'シート内の全てのセルに対してループを実行します。
Set myRange = mySheet.UsedRange

'***処理マクロ（フォント変更など）***
Next

として

'Next
myFile = Dir()

の所のNextを無効にしてください。

NewName = "C:\Users\XXXXXX\Desktop\NEM_macro\"修正後" & "\" & ThisName & 年月 & ".xlsx"
は
NewName = "C:\Users\XXXXXX\Desktop\NEM_macro\修正後" & "\" & ThisName & 年月 & ".xlsx"
ですね。

保存した後にファイルを閉じないと、どんどん開いたままになると思いますので、閉じたほうがいいのではないでしょうか。

ActiveWorkbook.SaveAs Filename:=NewName
ActiveWorkbook.Close

あとインデントしてないのでコードが見にくいです。

【解説つき】VBAでインデントするときのルール教えます【迷わない】
https://ziyuss.jp/vba-indent-rule/

お礼

毎度毎度ありがとうございます。インデント、きれいに揃えます。いただいたアイデア反映で解決しました。ありがとうございました。