前回の質問では､ﾍﾞｽﾄｱﾝｻｰおよびたくさんのﾎﾟｲﾝﾄを頂き､ありがとうございました｡

ｷｰﾜｰﾄﾞの数を変えるというのは､やはりこちらのﾊﾟﾀｰﾝだったのですね｡
難しく考えすぎていたようで､思ったよりも少ない修正で出来ました｡
以下のｺｰﾄﾞで確認してみて下さい｡

'置換対象ﾃﾞｰﾀ関連
Private Const TARGET_SHEET_NAME As String = "Sheet1"

'ﾌｨﾙﾀｰの基準となる列(G列)
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

  '2行以上連続していたら置換
 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