人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

前回の質問 http://q.hatena.ne.jp/1522512207 の続きになりまして。
前回はSheet2のB2からK2セルまで等、つまり、10個のキーワードでの置換でしたが。
3行目はA3セルのキーワードを、B3セルからZ3セルまでのキーワードで置換、
4行目はA4セルのキーワードを、B4セルからG4セルまでのキーワードで置換、
5行目はA5セルのキーワードを、B5セルからAHセルまでのキーワードで置換、

などなど。
各行、変えたいキーワードによって、置換したいキーワードの数が異なります。
その場合にはどのように処理すればよいのか、お手隙の時にご回答いただけますと助かります。

よろしくお願い致します。

●質問者: moon-fondu
●カテゴリ:コンピュータ 学習・教育
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● Z1000S
●2000ポイント ベストアンサー

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

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

'置換対象データ関連
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

moon-fonduさんのコメント
遅くなりましてすみません、ありがとうございます!

Z1000Sさんのコメント
ベストアンサーありがとうございます。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ