このバナーをクリックするとホームページに戻ります

エクセルVBA5「検索・抽出・表示」

エクセルで表を作成して、その中である記号に注目して検索したり、抽出したり、またすべての行を表示したいことがある。たとえば、一覧表の中で、○印をつけたものだけを抽出し、それを別のシートに表示する。また案内を出した人の名簿を作成していて、実際に参加した人を名簿の中で○印を入れて、それを一気に別シートに表に作成する。そのまま印刷も可能にするマクロもできる。

モジュールのソースをボタンでコピーできるようにしました。ホームページに載っているソースをコピーしようとしてドラッグしかけて、うまく全体がコピーできなかったことを今まで何度も経験していると、簡単にコピーできるほうがありがたい。そんな思いで一括コピーするボタンをつけてみました。もちろん私はエクセルVBAといっても本で読んだり、他の人のHPを参考にしながら、自分が利用しそうなものをまとめているだけで、自分なりに手を加えている箇所は非常に少ないだろうと思います。


「エクセルVBA事始め」に戻る

エクセルVBAのマクロの記述モジュールは緑の枠内に記述しています。「モジュールをコピーする」のボタンをクリックすると、このモジュール全体を一発でコピーします。それを貼り付けてマクロを実行してみてください。

このページの目次



1 文字列検索

2 全行を表示

3 参照セルを含む列の最終セル

4 検索データ件数

5 抽出貼付コピー別シート

6 抽出から表に整形



◆◆◆ 1 文字列検索 ◆◆◆

このマクロは、シートのA〜Hに表があり、その中のデータを検索するときに利用できる。大量のデータを入力した後、同一名で他の項目の表示が違うとき、いくつかの検索語句でand、orの検索ができる。ここでは、A2:H4の範囲に検索語句を記入し、and検索のときは検索窓の同一行に項目列にあった語句を記入し、or検索のときは別の行に語句を記入する。


Sub 文字列検索()
'
' 文字列検索 Macro
' マクロ記録日 : 2005/1/1  ユーザー名 : canchan
'A6 を含む表内を検索する
'A2:H4 で表示した文字を検索する

Range("A6").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A2:H4")
'Range("A2:H4")を行数を増やすと「3行目の文字」または「4行目の文字」という検索となる。同じ行の語句は and検索となる。
'Criteria1とはcriteriaの1番目といった感じ。抽出条件の1番目
End Sub

モジュールをコピーする





このページの目次に戻る


◆◆◆ 2 全行を表示 ◆◆◆

検索などで抽出表示をしたときに、その後、またすべての行を表示したいときにこのマクロを実行すると、一気に表示できる。オートシェイプでボタン枠を作り、それを右クリックで「マクロの登録」からこの全行表示を登録しておくと便利です。


Sub 全行を表示()
' 全行を表示 Macro
' マクロ記録日 : 2005/1/2  ユーザー名 : canchan
'検索などで抽出してその後全行を表示するときに使う
ActiveSheet.ShowAllData
End Sub


モジュールをコピーする


このページの目次に戻る


◆◆◆ 3 参照セルを含む列の最終セル ◆◆◆


Sub 参照セルを含む列の最終セル()
'
' 参照セルを含む入力セル矩形選択 Macro
' マクロ記録日 : 2005/1/16  ユーザー名 : canchan
'
Dim c As Range
On Error GoTo errMSG        'エラーで処理を分ける
Set c = Application.InputBox(prompt:="基準セルをクリックしてください", Type:=8)
'typeは 0:数式,1:数値,2:文字列,4:論理値(true/false) ,8:セル参照(Rangeオブジェクト),16:Excelのエラー値(#N/Aなど),64:数値配列
c.End(xlDown).Select
Exit Sub
'
If c = Range("") Then MsgBox "セルを選択せずにOKボタンが押されました。セルをクリックしてOKボタンを押してください。"

errMSG:      'ここからエラーによりメッセージを分ける
Select Case Err.Number
Case 13         '13 は「指定する型が違う。」
MsgBox "セルの位置をクリックしてください"

End Select

End Sub


モジュールをコピーする


このページの目次に戻る


◆◆◆ 4 検索データ件数 ◆◆◆

表の中に「田中」という文字がいくつあるか件数を求める。


Sub 検索データ件数()
'処理内容: リスト範囲の1行目を検索して検索データが見つかった件数を求めます
Dim TargetStr As String, LastRow As Integer
Dim TargetArea As Range, FoundCell As Range
Dim R As Integer, N As Integer
TargetStr = "田中"
LastRow = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
Set TargetArea = Range(Cells(1, 1), Cells(LastRow, 1))
Set FoundCell = TargetArea.Find(what:=TargetStr, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If Not FoundCell Is Nothing Then
R = FoundCell.Row
MsgBox "最初の検索行=" & R
N = 1
Do
Set FoundCell = TargetArea.FindNext(After:=FoundCell)
If FoundCell.Row = R Then Exit Do
N = N + 1
MsgBox N & "番目の検索行=" & FoundCell.Row
Loop
Else
MsgBox "該当データがありません", vbCritical
End If
MsgBox "見つかった件数 = " & N
Set FoundCell = Nothing
Set TargetArea = Nothing
End Sub


モジュールをコピーする


このページの目次に戻る


◆◆◆ 5 抽出貼付コピー別シート ◆◆◆

このマクロは、「抽出」とつけられたシートに、抽出されたデータをコピーして貼付をするものです。「抽出」と名前をつけたシートの記述をすべてクリアーします(何かのデータが重なることを防ぐため)。「sheet3」のA列で「o」「O」(オー)の入力されたデータを抽出し、「抽出」シートに貼り付けます。貼り付ける範囲は、A列〜C列の内容です。


Sub 抽出貼付コピー別シート()
' マクロ記録日 : 2004/3/13  ユーザー名 : canchan

Sheets("抽出").Select
Cells.Clear
Sheets("sheet3").Select
Range("A2").CurrentRegion.AutoFilter field:=1, Criteria1:="O"
Range("A2", Range("C2").End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Sheets("抽出").Range("A2").PasteSpecial Paste:=xlPasteValues

End Sub


モジュールをコピーする



このページの目次に戻る


◆◆◆ 6 抽出から表に整形 ◆◆◆

この記述は、次のような場面を想定している。 (1)「案内先」と名づけたシートに、A列にチェック欄。出席者にはアルファベットのオー「o」を入力する。B列には職名を表示している。C列は「ふりがな」。D列は「氏名」という構成である。
(2)このマクロはオートシェイプなどでボタンを作成して、出席のチェックを入れた後、そのボタンにと憂ー録したこのマクロを実行し、即印刷までできるようにしたものです。
(3)出席者のオー「o」がついた人の名簿を、「紹介」と名づけたシートに転記している。ただ、データがなくなったら困ると思って、抽出したデータは「紹介」のシートの101行以降にいったん記述し、そのデータを2行で表示できるように計算して書き直している。
(4)2列に書き直すときには1列目が、E列〜H列に、2列目がA列〜D列に表示するようにしている。


Sub 抽出から表に整形()
' マクロ記録日 : 2004/3/13  ユーザー名 : canchan

Sheets("紹介").Select
Range("A3:D200,E4:H200").Clear
Sheets("案内先").Select
Range("A2").CurrentRegion.AutoFilter field:=1, Criteria1:="O"   'Criteria1:="O"は検索条件
Range("A2", Range("D2").End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
Sheets("紹介").Range("A100").PasteSpecial Paste:=xlPasteValues

'Sub 行数の半分で下部左へ折り返す()
Dim 行数 As Long, 列数 As Long
Dim 行数の半分 As Long
Sheets("紹介").Select
'Range("A100")は項目名
行数 = Range("A100").CurrentRegion.Rows.Count
列数 = Range("A100").CurrentRegion.Columns.Count
'行数の半分 = 行数 / 2      '小数点のまま答えが出る
行数の半分 = 行数 \ 2       '円記号ですると、答えが整数部分だけとなる。切捨て。円記号がこの形にしか表示できない。フォントのせい?
'前半分を右に移動する。Aさん・Bさん・Cさんは指定席とする。Oも記入しない。1列目を一番右に配置する。1列目にA・Bさん、2列目にCさんを配置する。
Range(Cells(101, 1), Cells(101 + 行数の半分 - 2, 列数)).Cut Destination:=Range("E4")   '折返し位置
Range(Cells(101 + 行数の半分 - 1, 1), Cells(101 + 行数, 列数)).Cut Destination:=Range("A3")  '基準位置    '
'Range(Cells(100 + 1, 1), Cells(100 + 1 + 行数の半分 - 2, 列数)).Cut Destination:=Range("E4")   '折返し位置
'Range(Cells(100 + 行数の半分, 1), Cells(100 + 行数, 列数)).Cut Destination:=Range("A3")     '基準位置    '
Range("A2").CurrentRegion.Borders.LineStyle = xlContinuous
Range("A2").CurrentRegion.ShrinkToFit = True
'2部ずつ部単位で印刷.実際に印刷するときは下の行の最初の「'」を削除する。
'Worksheets("紹介").Range("A2").CurrentRegion.PrintOut copies:=2, collate:=True

End Sub


モジュールをコピーする



このページの目次に戻る





「エクセルVBA事始め」に戻る