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


今、Sheet1のG列のセルに、10万行ほどデータが入っています(空白セル含む)。
例えば「りんご」「りんご (銘柄名)」や、「牛肉」「牛肉 (銘柄名)」などです。

G列を見ると「りんご」を含むセルは、①3~8行目、②23~45行目・・・53000~53211行目など、規則性なく並んでます。

そして「牛肉」を含むセルは、③11・12行目、④35~45行目・・・72345~72600行目など、これまた規則性はありません。
この状況におきまして。

“りんご”というフレーズが出てきまして、それが連続してかたまりになっておりましたら。(①の状況)
それを、Sheet2のB2セルにある文字列「りんご 赤い」に、全て置換してほしいのです。
8行目までが置換されまして、9行目に空白セルがあれば、一旦リセットしていただいて。

さらにG列を進んでいき、また“りんご”を含むフレーズが出てきます。(②の状況)
そしたら今度はSheet2のC2セルにある文字列「りんご フルーツ」に、全て置換してほしいのです。

回答の条件
  • 1人10回まで
  • 登録:2018/04/01 01:03:27
  • 終了:2018/04/03 20:15:35
id:moon-fondu

(書ききれなかった質問の続きです)

45行目まで置換されまして、46行目に空白セルがあれば、またリセットし。
この流れを、Sheet2のK2セルまで、つまり、10個のキーワードで“りんご”を、固まりごとに置換したいのです。

K2セルまで完了しましたら“りんご”は終了で。
次にA3セル“牛肉”の置換を行い、同様にK3セルまで完了すれば。
A4セルのキーワード、Sheet1・G列を探して、B4~K4セルの文字列で置換、終わったらA5列のキーワード…と、この処理を続けたいのです。

判りにくい質問で恐縮です。空白セルが区切りとなり、うまくマクロ等で固まりごとに指定のキーワードで効率的に置換できたらありがたいのですが…可能でしたらご回答いただけますと助かります。
よろしくお願い致します<m(__)m>

ベストアンサー

id:Z1000S No.1

Z1000S回答回数11ベストアンサー獲得回数82018/04/01 15:33:30

ポイント2800pt

こんな感じですかね。

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

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

        '2行以上連続していたら置換
        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
他3件のコメントを見る
id:Z1000S

うまく動作してくれたようで、何よりです。

ただもし、可能であればお答えいただきたいのですが

今回のように、すべてのキーワードに対する置換文字列の数が固定(同じ)であるならば可能です。

Private Const REPLACE_WORDS_COUNT       As Long = 10

の10の部分を変えて下さい。

ただし、キーワード毎に数が違うというのであれば
別の方法を取る必要があります。(試してませんが、多分出来るでしょう)
それについては、ここですぐにコードを提示出来るようなものではありませんので、ご了承下さい。

もしどうしても、そのような処理が必要なのであれば、
新たな質問として投稿された方がよいかと思います。

では、頑張って下さい。

2018/04/02 21:31:58
id:Z1000S

「ベストアンサー」ありがとうございます。

2018/04/03 21:08:23

その他の回答(1件)

id:Z1000S No.1

Z1000S回答回数11ベストアンサー獲得回数82018/04/01 15:33:30ここでベストアンサー

ポイント2800pt

こんな感じですかね。

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

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

        '2行以上連続していたら置換
        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
他3件のコメントを見る
id:Z1000S

うまく動作してくれたようで、何よりです。

ただもし、可能であればお答えいただきたいのですが

今回のように、すべてのキーワードに対する置換文字列の数が固定(同じ)であるならば可能です。

Private Const REPLACE_WORDS_COUNT       As Long = 10

の10の部分を変えて下さい。

ただし、キーワード毎に数が違うというのであれば
別の方法を取る必要があります。(試してませんが、多分出来るでしょう)
それについては、ここですぐにコードを提示出来るようなものではありませんので、ご了承下さい。

もしどうしても、そのような処理が必要なのであれば、
新たな質問として投稿された方がよいかと思います。

では、頑張って下さい。

2018/04/02 21:31:58
id:Z1000S

「ベストアンサー」ありがとうございます。

2018/04/03 21:08:23
id:Asayuri No.2

Asayuri回答回数19ベストアンサー獲得回数62018/04/01 16:24:24

ポイント200pt

エクセルの関数式でファイルを作成してみました。

T列をコピーしてG列に値貼付けすれば ご希望のデータが出来上がります。

ご確認ください。よろしくお願いいたします。

次のURLからダウンロードしてください。
http://firestorage.jp/download/920a275b7ad1370e705933e185b51851aaa22e84
 

他2件のコメントを見る
id:moon-fondu

失礼しました、わかりにくくてすみません(;^_^
こちらが完成前 http://f.hatena.ne.jp/moon-fondu/20180402210144 で。
こちらが完成後 http://f.hatena.ne.jp/moon-fondu/20180402210147 です。

2018/04/02 21:07:45
id:Asayuri

 
完成前と 完成後イメージ画像で
 
空白行や 牛肉行は どこにあって どう変化させたいのでしょうか?
 
 

2018/04/02 22:02:30

コメントはまだありません

この質問への反応(ブックマークコメント)

トラックバック

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません