[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『語句の検索と抽出マクロ』(のぼ)
シート1に以下のような表があります。
A B C D
1 2011-10-10 太郎 麦わら帽子 123
2 2011-11-11 次郎 花柄帽子 234
3 2011-12-12 三郎 花柄洋服 345
4 2011-12-17 花子 麦色洋服 567
この表のC列の語句(例えば"麦")を検索して
シート2に以下のような表に変換したいのですが
A B C D
1 2011-10-10 太郎 麦わら帽子 123
2 2011-12-17 花子 麦色洋服 567
3
4
マクロを使い始めた初心者です。よろしくお願いいたします
Excel2000、WindowsXPを使用しています。
方法としては、
1 オートフィルタ(フィルタオプションでもよい)を使い、C列に 特定の文字列を含む行を絞り込む方法(絞込みは、Specialcellsメソッド等)。
AutoFilter で検索すれば使用方法が過去ログにきっとあります。 但し、例題データは1行目から始まっていますが、最初の行には、項目名が必要。
2 作業列(現在使っていない列、E列でもZ列等空いている列)に
数式を入力して(一例 =FIND("麦",C2) この数式の結果が数値の行だけ
絞り込む(Specialcellsメソッド)。
3 RangeオブジェクトのFindメソッド Findnextメソッドを使って
対象文字が含むセルを探していく(これは、今回の場合、注意事項もあります)。
オートフィルタのときだけ1行目は、項目名を入れると取り立てて記述しましたが、 Excelでデータベースに近い処理をする時は、 先頭行に項目行を入れることを習慣付けた方が良いですよ!! その方がExcelの機能を使いやすいので・・・・・
上記の手法を調べて見てください。 ここでは、1、2あたりかなあとは、思いますが、Findメソッドも 覚えておけば役に立ちます。
ichinose
ichinoseさんの回答の1,2,3それぞれのコード案。
Sub Test1AF() 'オートフィルタ
With Sheets("Sheet1") '元シートの規定
.AutoFilterMode = False 'すでにオートフィルタがセットされていれば、いったんリセット
.Range("A1").AutoFilter Field:=3, Criteria1:="*麦*" 'A1から始まるリスト領域にオートフィルタをセットし、C列をフィルタリング
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
(ぶらっと)
ありがとうございます 参考にさせていただきます
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.