[[20111217013817]]　『語句の検索と抽出マクロ』（のぼ）　ページの最後に飛ぶ

『語句の検索と抽出マクロ』（のぼ）

シート１に以下のような表があります。

　　Ａ　　　　　　　Ｂ　　　　　Ｃ　　　　　　　Ｄ

1　2011-10-10　太郎　麦わら帽子　123

2　2011-11-11　次郎　花柄帽子　　234　

3　2011-12-12　三郎　花柄洋服　　345

4　2011-12-17　花子　麦色洋服　　567

この表のＣ列の語句（例えば"麦"）を検索して
シート２に以下のような表に変換したいのですが

　　Ａ　　　　　　Ｂ　　　　　　Ｃ　　　　　　Ｄ

1　2011-10-10　太郎　麦わら帽子　123　

2　2011-12-17　花子　麦色洋服　　567　

マクロを使い始めた初心者です。よろしくお願いいたします
Excel2000、WindowsXPを使用しています。

 方法としては、

 １　オートフィルタ（フィルタオプションでもよい）を使い、Ｃ列に
 特定の文字列を含む行を絞り込む方法(絞込みは、Specialcellsメソッド等）。

 AutoFilter　で検索すれば使用方法が過去ログにきっとあります。 
 但し、例題データは１行目から始まっていますが、最初の行には、項目名が必要。

 ２　作業列（現在使っていない列、Ｅ列でもＺ列等空いている列）に
 　　数式を入力して（一例　=FIND("麦",C2)　この数式の結果が数値の行だけ
     絞り込む(Specialcellsメソッド）。

 ３　RangeオブジェクトのFindメソッド　Findnextメソッドを使って
    対象文字が含むセルを探していく（これは、今回の場合、注意事項もあります）。

 オートフィルタのときだけ１行目は、項目名を入れると取り立てて記述しましたが、
 Excelでデータベースに近い処理をする時は、
 先頭行に項目行を入れることを習慣付けた方が良いですよ!!
 その方がExcelの機能を使いやすいので・・・・・

 上記の手法を調べて見てください。
 ここでは、1、２あたりかなあとは、思いますが、Findメソッドも
 覚えておけば役に立ちます。

 ichinose

 ichinoseさんの回答の１，２，３それぞれのコード案。

 Sub Test1AF()   'オートフィルタ
    With Sheets("Sheet1")                                   '元シートの規定
        .AutoFilterMode = False                  'すでにオートフィルタがセットされていれば、いったんリセット
        .Range("A1").AutoFilter Field:=3, Criteria1:="*麦*"  'A1から始まるリスト領域にオートフィルタをセットし、Ｃ列をフィルタリング
        Sheets("Sheet2").Cells.ClearContents                '事前にSheet2をクリア
        .AutoFilter.Range.Copy Sheets("Sheet2").Range("A1")   '抽出イメージをコピーし、Sheet2に貼付
        .AutoFilterMode = False                  'オートフィルリセット
    End With
 End Sub

 Sub Test1FO()  'フィルタオプション
    With Sheets("Sheet1")                                   '元シートの規定
        .Range("F1").Value = Range("C1").Value               '検索条件用のタイトル項目
        .Range("F2").Value = "*麦*"                          '抽出条件
        Sheets("Sheet2").Cells.ClearContents                '事前にSheet2をクリア
        'フィルタオプションで抽出し結果をSheet2に書き込む
        .Columns("A:D").AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=.Range("F1:F2"), CopyToRange:=Sheets("Sheet2").Range("A1"), Unique:=False
        .Range("F1:F2").ClearContents                        '検索条件欄をクリア
    End With
 End Sub

 Sub Test2()  '作業列方式
    Dim z As Long
    Dim r As Range
    With Sheets("Sheet1")                                   '元シートの規定
        z = .Range("C" & .Rows.Count).End(xlUp).Row          '最終行番号
        .Range("E1:E" & z).Formula = "=FIND(""麦"",C1)"      '作業列に式の埋め込み
        Set r = .Columns("E").SpecialCells(xlCellTypeFormulas, 1)  '結果が数字のセル
        If r Is Nothing Then
            MsgBox "対象の文字列がありません"
        Else
            Sheets("Sheet2").Cells.ClearContents            '事前にSheet2をクリア
            r.EntireRow.Copy Sheets("Sheet2").Range("A1")   '抽出イメージをコピーし、Sheet2に貼付
            Set r = Nothing
            .Columns("E").ClearContents                     '作業列をクリア
        End If
    End With

 End Sub

 Sub Test3() 'Find方式
    Dim c As Range
    Dim f As Range
    Dim z As Long
    Dim r As Range

    With Sheets("Sheet1")                                   '元シートの規定
        Set c = .Columns("C").Find(What:="麦", LookIn:=xlFormulas, LookAt:=xlPart)
        If c Is Nothing Then
            MsgBox "対象の文字列がありません"
        Else
            Set f = c
            Do
                If r Is Nothing Then
                    Set r = c
                Else
                    Set r = Union(r, c)
                End If

                Set c = .Columns("C").FindNext(c)
                If c Is Nothing Then Exit Do
            Loop While c.Address <> f.Address
            Set c = Nothing
            Set f = Nothing
            Sheets("Sheet2").Cells.ClearContents            '事前にSheet2をクリア
            r.EntireRow.Copy Sheets("Sheet2").Range("A1")   '抽出イメージをコピーし、Sheet2に貼付
            Set r = Nothing
        End If
    End With

 End Sub

 (ぶらっと)

ichinose様　ぶらっと様

ありがとうございます　参考にさせていただきます

コメント返信：

[ 一覧(最新更新順) ]

[[20111217013817]] 『語句の検索と抽出マクロ』（のぼ） ページの最後に飛ぶ

[[20111217013817]]　『語句の検索と抽出マクロ』（のぼ）　ページの最後に飛ぶ