EXCELマクロ、ループかけるとマクロが固まる

質問

「フォルダ内の全てのExcelファイルに対してループを実行する」マクロを組むと、カーソルがぐるぐるして正常に起動していないように思えます。ループ無しであればさくさく動きます。ループ無しの場合は、ファイル１つ１つを自分で開けてマクロを起動。マクロは下記の通り。初心者です。

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

Application.ScreenUpdating = False

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

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

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

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

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

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

End With

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
ActiveSheet.UsedRange.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

Next

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

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

End Sub

回答No.1

kkkkkm · ベストアンサー

> Set myRange = mySheet.UsedRange
> For Each cell In myRange
>
> Cells.Select

これはUsedRange分の回数分シートの全てのセルを選択してFontの指定やReplaceを行っていることになると思いますから、UsedRangeが10個あれば10回全てのセルにたいしてその操作行われています。

シートの全てのセルにたいして操作するのではなくcellにしたいのでしたら

cell.Select

とするか、間違わないように変数にcellを使わないようにした方がいいです。

また、
〇〇.Selectのあとに
Selection.△△としなくても
直接
〇〇.△△
にしたほうがいいと思います。

> Set myRange = mySheet.UsedRange
> For Each cell In myRange
の中に

> ActiveSheet.UsedRange.Select
>
> For Each セル In Selection

があると思いますが、同じところを2回ループしているのではないでしょうか。

テキストボックス関連も
> Set myRange = mySheet.UsedRange
> For Each cell In myRange

の外に出さないとUsedRange分同じことを繰り返していると思います。

> myFile = Dir()
> Next
> Loop

は

Next
myFile = Dir()
Loop

じゃないでしょうか。

お礼

ありがとうございました。ご指摘箇所を反映してみます！