Макрос Excel 2013, вызванный циклом через макрос, работает только на одном листе

Question

Пожалуйста, извините меня за ошибки в публикации и правилах и т. Д. Я ноль в макросе и публикации на форумах. В большой базе данных мне нужно изменить цвет нескольких имен. Первая часть макроса я нашел на веб-странице Microsoft. Вторая часть, которую я записал.

Макрос работает только на одном листе. Несмотря на обширный поиск, не могу найти ответ. Пожалуйста, руководство, помощь, исправить. Я ценю и благодарю вас заранее.

Sub ChangeName_DifferentColor_Loop()

    'ChangeName_DifferentColor_Loop
    'Declare Current as a worksheet object variable.

    Dim Current As Worksheet
    'Loop through all of the worksheets in the active workbook.
    For Each Current In Worksheets
        Call ChangeName_DifferentColor_SingleSheet
        ' This line displays the worksheet name in a message box.
        MsgBox Current.Name
    Next
End Sub

-------------------------------
'Insert you Code Here.
Sub ChangeName_DifferentColor_SingleSheet()      '
    ' ChangeName_DifferentColor_SingleSheet Macro
    '
    Columns("A:A").Select
    Range("A1048545").Activate
    With Application.ReplaceFormat.Font
        Strikethrough = False
        Superscript = False
        Subscript = False
        color = 192
        TintAndShade = 0
    End With
    Selection.Replace What:="Mike", Replacement:="Mike", LookAt:=xlPart, _
                      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                      ReplaceFormat:=True
    Selection.Replace What:="Della", Replacement:="Della", LookAt:=xlPart, _
                      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                      ReplaceFormat:=True
    Selection.Replace What:="Ike", Replacement:="Ike", LookAt:=xlPart, _
                      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                      ReplaceFormat:=True
    Selection.Replace What:="Shan", Replacement:="Shan", LookAt:=xlPart, _
                      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                      ReplaceFormat:=True
    With Application.ReplaceFormat.Font
        Strikethrough = False
        Superscript = False
        Subscript = False
        color = 255
        TintAndShade = 0
    End With
    ReplaceFormat:=True
    ActiveWorkbook.Save
    enter code here
End Sub

---

Спасибо.

Answer 1

Вы можете попробовать это:

1. Вам следует избегать зависимости от .Selection. Вместо этого явно укажите диапазон. Здесь диапазон будет от столбца A от A1 до последней использованной строки в столбце A (LRow). Этот диапазон обозначается как CurrentRange в коде.
2. Вам необходимо добавить префикс в свойствах With к .
3. Вы можете удалить параметры в Replace, для которых установлено значение False. Если не указано, по умолчанию они будут False
4. Отключить ScreenUpdating, чтобы ускорить время выполнения

---

Option Explicit

Sub ChangeName_DifferentColor_Loop()

Dim Current As Worksheet
Dim LRow As Long
Dim CurrentRange As Range

Application.ScreenUpdating = False
    For Each Current In Worksheets
        MsgBox Current.Name

        LRow = Current.Range("A" & Current.Rows.Count).End(xlUp).Row
        CurrentRange = Current.Range("A1:A" & LRow)

            With Application.ReplaceFormat.Font
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .Color = 192
                .TintAndShade = 0
            End With

                CurrentRange.Replace What:="Mike", Replacement:="Mike", LookAt:=xlPart, _
                    SearchOrder:=xlByRows, ReplaceFormat:=True
                CurrentRange.Replace What:="Della", Replacement:="Della", LookAt:=xlPart, _
                    ReplaceFormat:=True
                CurrentRange.Replace What:="Ike", Replacement:="Ike", LookAt:=xlPart, _
                    ReplaceFormat:=True
                CurrentRange.Replace What:="Shan", Replacement:="Shan", LookAt:=xlPart, _
                    SearchOrder:=xlByRows, ReplaceFormat:=True

            With Application.ReplaceFormat.Font
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .Color = 255
                .TintAndShade = 0
            End With

    Next Current
Application.ScreenUpdating = True

End Sub