Excelマクロループセル/シートにループ

質問

いつもお世話になります。
ずっと同じマクロについて質問しております。
アドバイスいただいた通りにしたつもりですが、現在セルとシートにループがかかっていないようで
マクロをかけたファイルを見ても、変更がファイルの最後のページにしか反映されていないです。
お手数ですが改めて下記マクロをどのように修正すべきか教えてください。

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\NXXXXX\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 = "C:\Users\NXXXXX\Desktop\NEM_macro\修正後" & "\" & ThisName & 年月 & ".xlsx"

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

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

myFile = Dir()

Loop

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

End Sub

回答No.1

kkkkkm · ベストアンサー

> 現在セルとシートにループがかかっていないようで

シートは以下でループしてますが
For Each mySheet In myBook.Sheets

Replaceではセルのループはしていないと思います。
半角全角修正では
Range("A1").CurrentRegion.
にたいしてループしていると思います。

> Selection.Replace What:="、", Replacement:="，"

この時点で、開いたファイルで前回保存時に選択されていたセルの文字を置換していますが、そのセルに該当する文字が無ければ何も起こりません。Selectionではなくセルを直接指定したほうがいいのではないでしょうか。

> Next
> '次のファイルに移動します。
>
>
> myFile = Dir()
>
> Loop

上記のNextは
For Each mySheet In myBook.Sheets
のNextだと思いますが、シートを変更する毎に毎回ファイルを保存するのでなく、シートを全て変更した後で保存するのであれば

> Dim 年月

の前にNextがあればいいのではないでしょうか。前回はそのつもりで回答しました。

とりあえず、一度にすべての事をやろうとせずに、一つの事が完成してから他の事を追加していくようにした方が分かりやすいと思います。

回答No.2

kkkkkm

No.1の補足です。

説明不足のような感じがしたので

> Range("A1").CurrentRegion.
> にたいしてループしていると思います。

A1が孤立していなければA1を含む範囲でループとなりますが、孤立している場合はA1だけが対象になりますからループとは言えないので。

お礼

いつもありがとうございます！