念仏寺とフォルクローレトップページに戻ります

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

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

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


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

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

このページの目次



1　文字列検索

2　全行を表示

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

4　検索データ件数

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

6　抽出から表に整形

7　漢字を取得しセルに書き出す



◆◆◆　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")を行数を増やすと「３行目の文字」または「4行目の文字」という検索となる。同じ行の語句は and検索となる。
'Criteria1とはcriteriaの１番目といった感じ。抽出条件の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は　０：数式，１：数値，２：文字列，４：論理値（true/false) ,８：セル参照(Rangeオブジェクト），１６：Excelのエラー値(#N/Aなど），６４：数値配列
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
モジュールをコピーする


このページの目次に戻る


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

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


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
モジュールをコピーする


このページの目次に戻る


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

このマクロは、｢抽出｣とつけられたシートに、抽出されたデータをコピーして貼付をするものです。｢抽出｣と名前をつけたシートの記述をすべてクリアーします(何かのデータが重なることを防ぐため)。「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
モジュールをコピーする



このページの目次に戻る


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

この記述は、次のような場面を想定している。 （１）｢案内先｣と名づけたシートに、A列にチェック欄。出席者にはアルファベットのｵｰ「o」を入力する。B列には職名を表示している。C列は「ふりがな」。D列は｢氏名｣という構成である。
（２）このマクロはオートシェイプなどでボタンを作成して、出席のチェックを入れた後、そのボタンにと憂ー録したこのマクロを実行し、即印刷までできるようにしたものです。
（３）出席者のｵｰ「o」がついた人の名簿を、｢紹介｣と名づけたシートに転記している。ただ、データがなくなったら困ると思って、抽出したデータは｢紹介｣のシートの101行以降にいったん記述し、そのデータを2行で表示できるように計算して書き直している。
（４）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
モジュールをコピーする



このページの目次に戻る


◆◆◆　7　漢字を取得しセルに書き出す　◆◆◆

セル内の文章の中でいくつかの漢字にルビを振ろうとしてセルをルビ表示にすると、すべての漢字が入力したときのルビが表示されてしまう。２，３の漢字だけでよいのに、不必要な漢字のルビを編集で削除するのは細かい作業となり、大変です。またどこかからコピーしてセルに貼り付けた文章であれば、ルビ表示にしてもルビが表示されない。そこでそのような必要がある時に、セルの中の漢字を取得し、セルに一つ一つ書き出し、必要なところだけルビとしての文字を入力しておけばよい。ここでは漢字を抜き出すマクロを書き留めておく。[々][〃]も取得するとしたが、「二」のくずしのユニコード「U+303B」は取得できない。

下のサンプルファイルでは漢字の抜き出しとともに、ルビの追加もできます。マクロを有効にして利用してください。


Sub 漢字を取得し書き出す()
'http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_regexp.html を参考
'http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=38762;id=excel  を参考
  Dim RE, Match, Matches
  Dim strPat As String      '検索文字のパターン（漢字、ひらがな、アルファベットなど）
  Dim strTest As String     '検索する文字列
  Dim strAns As String
    strTest = Range("A6").Value     'A6セル----検索される文字列
    Set RE = CreateObject("VBScript.RegExp")
    strPat = "([一-龠|々|&H303B|〃]+)"    
'----検索するパターンを「漢字」に指定,[々][〃]の2つを追加　
'「&H303B」は繰り返しの「二」のくずしのユニコード「U+303B」･･･取得できていない
    With RE
        .Pattern = strPat     '----パターンを設定します
        .IgnoreCase = True '----大文字と小文字を区別するFalseか、しないTrueか
        .Global = True       '----文字列全体を検索するTrueか、しないFalseか
    End With
    Set Matches = RE.Execute(strTest)
  '  MsgBox Matches.Count & "個見つかりました。"
    For Each Match In Matches
'         strAns = strAns & "一致する文字列が見つかった位置は、" & Match.FirstIndex & " です。" & _
                                "一致した文字列は、" & Match.Value & " です。" & vbCrLf
         strAns = strAns & Match.Value & vbCrLf     '漢字のデータだけを改行して示す
'vbCrLf はVBAでテキストでの改行。エクセルセル内の改行は「vbLf」.
    Next
  '  MsgBox strAns
    'Range("C3").Value = strAns
    Range(Cells(3, 3), Cells(3, 3 + Matches.Count - 1)) = Split(strAns, vbCrLf)
    'C3セルから必要漢字数に応じて、同じ行の横に漢字を書きだします。
    'http://officetanaka.net/excel/vba/tips/tips124.htm を参考
End Sub
モジュールをコピーする


このページの目次に戻る





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