Excelで連続して固まっているデータ毎に、指定の10個のキーワードでそれぞれ置換したい

こんな感じですかね。

１０万件のデータが無いので、どの程度のレスポンスになるかわかりませんが・・・

'置換対象データ関連
Private Const TARGET_SHEET_NAME     As String = "Sheet1"

'フィルターの基準となる列（Ｇ列）
Private Const TARGET_COL            As Long = 7


'キーワード関連
Private Const KEYWORDS_SHEET_NAME   As String = "Sheet2"

Private Const KEYWORDS_BEGIN_ROW    As Long = 2

Private Const MAIN_KEYWORDS_COL     As Long = 1

Private Const REPLACE_WORDS_BEGIN_COL   As Long = 2

Private Const REPLACE_WORDS_COUNT       As Long = 10


Public Sub replaceCellsMain()

    Dim wsKeywords      As Worksheet
    Dim wsTarget        As Worksheet
    Dim lKeywordsCount  As Long
    Dim sReplaceWords(REPLACE_WORDS_COUNT - 1)  As String
    Dim sMainKeywords   As String
    Dim lTargetRows()   As Long
    Dim lTargetRowsCount    As Long
    Dim i               As Long

    Application.ScreenUpdating = False

    Set wsTarget = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
    Set wsKeywords = ThisWorkbook.Worksheets(KEYWORDS_SHEET_NAME)

    '置換するキーワード数取得
    lKeywordsCount = getKeywordsCount(wsKeywords)

    For i = 0 To lKeywordsCount - 1
        '置換するキーワードと置換後の文字列取得
        sMainKeywords = getKeywords(wsKeywords, i, sReplaceWords)

        'キーワードが含まれる行を格納する配列の初期化
        ReDim lTargetRow(0)

        'キーワードが含まれる行の取得
        lTargetRowsCount = getTargetRows(wsTarget, sMainKeywords, lTargetRows)

        If lTargetRowsCount > 0 Then
            '置換
            Call replaceCells(wsTarget, sMainKeywords, lTargetRows, sReplaceWords)
        End If

        Debug.Print sMainKeywords & " Done."
    Next i

    Set wsKeywords = Nothing
    Set wsTarget = Nothing

    Application.ScreenUpdating = True

End Sub

Private Function getKeywordsCount(ByRef ws As Worksheet) As Long

    Dim lEndRow As Long

    lEndRow = ws.Cells(ws.Rows.Count, MAIN_KEYWORDS_COL).End(xlUp).Row

    getKeywordsCount = lEndRow - KEYWORDS_BEGIN_ROW + 1

End Function

Private Function getKeywords(ByRef ws As Worksheet, ByVal lIndex As Long, ByRef sKeywords() As String) As String

    Dim i       As Long

    For i = 0 To REPLACE_WORDS_COUNT - 1
        sKeywords(i) = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, REPLACE_WORDS_BEGIN_COL + i).Value
    Next i

    getKeywords = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, MAIN_KEYWORDS_COL).Value

End Function

Private Function getTargetRows(ByRef ws As Worksheet, ByVal sKeyword As String, ByRef lTargetRows() As Long) As Long

    Dim xlFilterRow     As Range
    Dim lHeaderRow      As Long
    Dim lEndRow         As Long
    Dim lTargetCounts   As Long
    Dim lCount          As Long

    With ws
        'オートフィルタの設定状態
        If .AutoFilterMode = True Then
            'オートフィルタが設定済みなら、一旦解除
            .AutoFilter.Range.AutoFilter
        End If

        'オートフィルタのヘッダとなるダミー行を挿入
        .Rows(1).Insert
        lHeaderRow = 1
        .Cells(lHeaderRow, TARGET_COL).Value = "DummyHeader"

        '終了行
        lEndRow = .Cells(.Rows.Count, TARGET_COL).End(xlUp).Row

        '指定文字データを抽出
        With .Range(.Cells(1, TARGET_COL), .Cells(lEndRow, TARGET_COL))
            'オートフィルタ実行
            .AutoFilter Field:=1, Criteria1:="=*" & sKeyword & "*"

            '絞り込まれた件数取得（ヘッダー行が含まれているため補正）
            lTargetCounts = .SpecialCells(xlCellTypeVisible).Count - lHeaderRow

            If lTargetCounts > 0 Then
                '対象の行を格納する配列初期化
                ReDim lTargetRows(lTargetCounts - 1)

                For Each xlFilterRow In .SpecialCells(xlVisible)
                    '対象データの行の取得
                    If xlFilterRow.Row > lHeaderRow Then
                        'ヘッダー行以降
                        lTargetRows(lCount) = xlFilterRow.Row - lHeaderRow

                        lCount = lCount + 1
                    End If
                Next xlFilterRow
            End If
        End With

        'オートフィルタ解除
        .AutoFilter.Range.AutoFilter

        'ダミーヘッダー行削除
        .Rows(1).Delete
    End With

    getTargetRows = lTargetCounts

End Function

Private Sub replaceCells(ByRef wsTarget As Worksheet, ByVal sMainKeywords As String, ByRef lTargetRows() As Long, ByRef sReplaceWords() As String)

    Dim lBeginRow   As Long
    Dim lEndRow     As Long
    Dim lTargetIndex    As Long
    Dim lTargetCount    As Long
    Dim lReplaceIndex   As Long
    Dim i               As Long

    lTargetIndex = 0
    lReplaceIndex = 0

    Do Until (lTargetIndex > UBound(lTargetRows)) Or (lReplaceIndex > UBound(sReplaceWords))
        lBeginRow = lTargetRows(lTargetIndex)

        lEndRow = lBeginRow

        lTargetCount = 1

        '値の連続した最終行を取得
        For i = 1 To UBound(lTargetRows) - lTargetIndex
            If lTargetRows(lTargetIndex + i) = lEndRow + 1 Then
                lEndRow = lEndRow + 1

                lTargetCount = lTargetCount + 1
            Else
                Exit For
            End If
        Next i

        '２行以上連続していたら置換
        If lEndRow > lBeginRow Then
            With wsTarget
                '置換
                .Range(.Cells(lBeginRow, TARGET_COL), .Cells(lEndRow, TARGET_COL)).Replace What:=sMainKeywords, Replacement:=sReplaceWords(lReplaceIndex), LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False
            End With

            lTargetIndex = lTargetIndex + lTargetCount

            lReplaceIndex = lReplaceIndex + 1
        Else
            lTargetIndex = lTargetIndex + 1
        End If
    Loop

End Sub