Excelで連続して固まっているデータ毎に、別シートにある各行それぞれのキーワードで置換したい

前回の質問では、ベストアンサーおよびたくさんのポイントを頂き、ありがとうございました。

キーワードの数を変えるというのは、やはりこちらのパターンだったのですね。
難しく考えすぎていたようで、思ったよりも少ない修正で出来ました。
以下のコードで確認してみて下さい。

'置換対象データ関連
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 Type ReplaceInformation
    sKeyword        As String
    lCount          As Long
    sReplaceWords() As String
End Type

Public Sub replaceCellsMain()

    Dim wsKeywords      As Worksheet
    Dim wsTarget        As Worksheet
    Dim lKeywordsCount  As Long
    Dim ReplaceInfo     As ReplaceInformation
    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
        '置換するキーワードと置換後の文字列取得
        Call getKeywords(wsKeywords, i, ReplaceInfo)

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

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

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

        Debug.Print ReplaceInfo.sKeyword & " 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 Sub getKeywords(ByRef ws As Worksheet, ByVal lIndex As Long, ByRef ReplaceInfo As ReplaceInformation)

    Dim sReplaceWord    As String

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

    ReplaceInfo.lCount = 0
    ReDim ReplaceInfo.sReplaceWords(0)

    sReplaceWord = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, REPLACE_WORDS_BEGIN_COL).Value

    Do Until sReplaceWord = ""
        ReDim Preserve ReplaceInfo.sReplaceWords(ReplaceInfo.lCount)

        ReplaceInfo.sReplaceWords(ReplaceInfo.lCount) = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, REPLACE_WORDS_BEGIN_COL + ReplaceInfo.lCount).Value
        ReplaceInfo.lCount = ReplaceInfo.lCount + 1

        sReplaceWord = ws.Cells(KEYWORDS_BEGIN_ROW + lIndex, REPLACE_WORDS_BEGIN_COL + ReplaceInfo.lCount).Value
    Loop

End Sub

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, ByRef lTargetRows() As Long, ByRef ReplaceInfo As ReplaceInformation)

    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 > ReplaceInfo.lCount - 1)
        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:=ReplaceInfo.sKeyword, Replacement:=ReplaceInfo.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