Excelマクロ、Loopが望まぬところにかかる

質問

いつもお世話になってます。マクロ初心者です。
下記マクロもコピペで作りました。先日あまりに時間がかかるので相談したら
回答いただいたのですが、別の問題が出てきました。
フォルダ内のすべてのファイルに実施するLoopが、
フォント変更などのマクロを実施して保存されたファイルに、もう一度マクロがかかる仕組みになっています。
故にマクロをスタートさせると、ファイル名がどんどん長いファイルが増えていって
作業が永遠に終わりません。
既述の通り、マクロのつぎはぎで作成したので
どこがどう問題なのか突き詰めることができません。
分かる方がいればご教示いただけますと幸いです。

******
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

'インジケーター表示
Dim j As Long
Info.Show vbModeless

'フォントを変更するファイルが保存されているフォルダのパスを指定します。
myPath = "C:\Users\XXXXX\Desktop\NEM_macro"

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

Do While myFile <> ""

'インジケーター
For j = 1 To 30000
With Info
.ProgressBar1.Value = j
.パーセント.Caption = Int(j / 30000 * 100) & "%"
.Repaint

End With
Next j

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

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

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

Cells.Font.Name = "ＭＳ Ｐゴシック"
Cells.Font.Name = "Arial"

Selection.Replace What:="、", Replacement:="，"
Selection.Replace What:="※", Replacement:="*"
Selection.Replace What:="①", Replacement:="(1)"
Selection.Replace What:="②", Replacement:="(2)"
Selection.Replace What:="③", Replacement:="(3)"
Selection.Replace What:="④", Replacement:="(4)"
Selection.Replace What:="⑤", Replacement:="(5)"
Selection.Replace What:="⑥", Replacement:="(6)"
Selection.Replace What:="⑦", Replacement:="(7)"
Selection.Replace What:="⑧", Replacement:="(8)"
Selection.Replace What:="⑨", Replacement:="(9)"
Selection.Replace What:="⑩", Replacement:="(10)"

'半角全角修正
Dim セル As Range
Dim 変換文字 As String
Dim 半角 As String
Dim i As Long
Range("A1").CurrentRegion.Select
For Each セル In Selection
変換文字 = StrConv(セル.Text, vbWide)
For i = 1 To Len(変換文字)
半角 = StrConv(Mid(変換文字, i, 1), vbNarrow)
If Asc(半角) >= 32 And Asc(半角) <= 126 Then _
変換文字 = WorksheetFunction.Replace(変換文字, i, 1, 半角)
Next i
セル = 変換文字
Next

'テキストボックスグループ化解除
Dim mySPg As Shape
For Each mySPg In ActiveSheet.Shapes
If mySPg.Type = msoGroup Then
mySPg.Ungroup

End If
Next mySPg

Dim mySP As Shape

'すべての図形テキストボックスをループ
For Each mySP In ActiveSheet.Shapes

'テキストボックスの場合
If mySP.Type = msoTextBox Then

'フォント変更
mySP.TextFrame2.TextRange.Font.NameFarEast = "ＭＳ Ｐゴシック"
mySP.TextFrame2.TextRange.Font.NameFarEast = "Arial"
End If
Next mySP

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 = ActiveWorkbook.Path & "\" & ThisName & 年月 & ".xlsx"

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

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

Next
myFile = Dir()

Loop

Info.Hide
MsgBox "処理が終了しました。"
Unload Info

End Sub

回答No.1

redslove10 · ベストアンサー

まず最初にファイル一覧を作成し、その後にその一覧にあるファイルだけに処理をかけるようにすれば良いでしょう。
今のコードだと、処理の過程で当該ディレクトリにファイルが増えたら、そのファイルも処理対象になってしまいます。

第21回.ファイル一覧を取得する（Do～LoopとDir関数）
https://excel-ubara.com/excelvba1r/EXCELVBA521.html

お礼

多分分かる人には当たり前なんですよね///　アドバイスありがとうございました！勉強していきます。