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
お礼
先頭に＠があるためにエラーで止まっているのが原因でした、ご迷惑をおかけしました。