[[20240729132622]]　『特定文字を含む行だけ別シート抽出したい』（福寿）　ページの最後に飛ぶ

『特定文字を含む行だけ別シート抽出したい』（福寿）

特定文字「メルマガ配信」を含む行だけ別シート抽出する下記マクロを変更して、特定文字を「メルマガ配信」と「メール配信」と「LINE配信」の3つが含まれる行を別シートへ切り取りたいのですがどのように変更した良いか教えてください。
Sub key1_転記()

    Dim key1 As String
    key1 = "メルマガ配信"
    Dim ws1 As Worksheet
    Set ws1 = Worksheets("編集用")
    Dim ws2 As Worksheet
    Set ws2 = Worksheets.Add(after:=ws1)
    ws2.Name = "その他項目"
    Dim k As Long
    k = 2
    Dim rng As Range
    Dim keyword As Variant

    If key1 = "" Then: Exit Sub
    Dim i As Long
    For i = 1 To ws1.UsedRange.Rows.Count
        If i = 1 Then
            ws1.Rows(1).Copy (ws2.Rows(1))
        End If
        If i >= 2 Then
            Set rng = ws1.UsedRange.Rows(i)
            For Each keyword In Split(key1, ",")
                If Not rng.Find(keyword, Lookat:=xlPart) Is Nothing Then
                    ws1.Rows(i).Copy (ws2.Rows(k))
                    k = k + 1
                    Exit For
                End If
            Next

        End If
    Next
End Su

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

 もこな２さんにおまかせします。
（マナ） 2024/07/29(月) 15:02:58

マナさん　ありがとうございます。
変更してみます。
（福寿） 2024/07/29(月) 18:06:32

 修正
 key1 = "メルマガ配信メール配信,「LINE配信"
       ↓
 key1 = "メルマガ配信,メール配信,LINE配信"
（マナ） 2024/07/29(月) 18:58:40

既に回答のあるところですが何点か。

■１
提示のコードはどこまで理解できていますか？
コードを改造しようとおもうのであれば、まずは現状のコードを理解するところから手を付けることをお勧めします。

提示のコードの冗長と思われる部分を整理してみると↓のようになります。

    Sub key1_転記()
        Dim key1 As String
        Dim k As Long, i As Long
        Dim keyword As Variant

        key1 = "メルマガ配信"
        k = 2

        With Worksheets("編集用").UsedRange
            Worksheets.Add(after:=Worksheets(.Parent.Name)).Name = "その他項目"
            .Rows(1).Copy Worksheets("その他項目").Cells(1, "A")

            For i = 2 To .Rows.Count
                For Each keyword In Split(key1, ",")
                    If Not .Rows(i).Find(keyword, Lookat:=xlPart) Is Nothing Then
                        .Rows(i).Copy Worksheets("その他項目").Cells(k, "A")
                        k = k + 1
                    End If
                Next keyword
            Next i
        End With
    End Sub

順番に見ていけばわかるかと思いますが↓の部分で「メルマガ配信」という文字列を「,」で区切って順番に「keyword」という変数に入れていますよね

 For Each keyword In Split(key1, ",")

■２
したがって端的に言えば↓のように修正すればＯＫです。

 修正前　 key1 = "メルマガ配信"
 修正前　 key1 = "メルマガ配信,メール配信,LINE配信"

ただ、上記の修正だけだと同じ行で複数のヒットがあったときに、ダブってコピーすることになってしまいます。
おそらく同じ行でヒットしてもコピーは１度でよいでしょうから↓のように、処理（コピー）をしたらループ処理を抜けるようにするとよいでしょう。

                For Each keyword In Split(key1, ",")
                    If Not .Rows(i).Find(keyword, Lookat:=xlPart) Is Nothing Then
                        .Rows(i).Copy Worksheets("その他項目").Cells(k, "A")
                        k = k + 1
                        Exit For '★ここにループを抜ける処理を追加
                    End If
                Next keyword

■３
なお、どのくらいデータがあるのかにもよりますが、現行の1行ずつ処理する部分を、対象の行を覚えておいてまとめてコピーするようにすることで処理速度アップが望める可能性があるとおもいます。
研究用のコードを提示しますので、興味があればステップ実行によりどのようなことをしているのか調べてみてください。

    Sub 研究用()
        Dim key1 As String
        Dim i As Long
        Dim keyword As Variant
        Dim コピー範囲 As Range

        key1 = "メルマガ配信,メール配信,LINE配信"
        Stop 'ブレークポイントの代わり

        With Worksheets("編集用").UsedRange
            Set コピー範囲 = .Rows(1)

            For i = 2 To .Rows.Count
                For Each keyword In Split(key1, ",")
                    If Not .Rows(i).Find(keyword, Lookat:=xlPart) Is Nothing Then
                        Set コピー範囲 = Union(コピー範囲, .Rows(i))
                        Exit For
                    End If
                Next keyword
            Next i
        End With

        With Worksheets.Add(after:=Worksheets("編集用"))
            .Name = "その他項目"
            コピー範囲.Copy .Range("A1")
        End With
    End Sub

（もこな２） 2024/07/29(月) 19:02:25

もこな２さん　ありがとうございます。
勉強してみます。

（福寿） 2024/07/30(火) 12:38:11

コメント返信：

[ 一覧(最新更新順) ]

[[20240729132622]] 『特定文字を含む行だけ別シート抽出したい』（福寿） ページの最後に飛ぶ

[[20240729132622]]　『特定文字を含む行だけ別シート抽出したい』（福寿）　ページの最後に飛ぶ