サンプル集  >  Excel VBA  >  検索結果を含む行を別Bookにコピー
検索結果を含む行を別Bookにコピー
2006/10/24

検索結果を含む行を新しいBookにコピーします。

◆環境
OS Windows 2000 Professional
Excel 2000(9.0.2812)
VBA 6.0.8435

EVBA006.xls
 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
'================================================================
' 2006/08/28 (c) ymlib.com
' 検索結果を含む行を別Bookにコピー
'================================================================
Option Explicit

' 検索メソッド
Private Sub CommandButton1_Click()

    Dim rgArea      As Range           ' 検索対象領域
    Dim strFindArea As String          ' 検索対象領域列名
    Dim strKey      As String          ' 検索キー
    Dim rgFind      As Range           ' 検索がヒットしたセル
    Dim rgBuf       As Range           ' 一時領域
    Dim strStAddr   As String          ' 検索が最初にヒットした
                                       ' セルのアドレス
    Dim rgSel       As Range           ' 選択行を溜め込むRange
    Dim strRow      As String          ' ヒットしたセルの縦位置
    Dim wbNew       As Workbook        ' 新規ワークブック

    ' 検索範囲を取得
    strFindArea = InputBox("検索する列を入力して下さい。例:C")
    Set rgArea = Range(strFindArea + ":" + strFindArea)

    ' 検索文字列を取得
    strKey = InputBox("検索する文字列を入力して下さい。")

    With rgArea

        ' 検索
        Set rgFind = .Find(strKey, LookIn:=xlValues)

        ' ヒットしたかチェック
        If rgFind Is Nothing Then
            ' 1件も該当しない場合、終了
            Exit Sub
        End If

        ' 初回ヒット時の位置を保存
        strStAddr = rgFind.Address

        ' ヒットした領域を取得
        Set rgBuf = Range(strStAddr)

        ' ヒットした領域を含む行を取得
        strRow = Trim(Str(rgBuf.Row))
        Set rgSel = Range(strRow + ":" + strRow)

        ' 検索を続ける
        Do
            ' 続けて検索
            Set rgFind = .FindNext(rgFind)

            If (rgFind Is Nothing) _
            Or (rgFind.Address = strStAddr) Then
                ' ヒットしなかった場合、もしくは
                ' 最初にヒットした位置と同じ位置が
                ' ヒットしたら検索終了
                Exit Do
            End If

            ' ヒットした領域を含む行を選択し、Rangeに溜め込む
            strRow = Trim(Str(rgFind.Row))
            Set rgSel = Union(rgSel _
                            , Range(strRow + ":" + strRow))
        Loop
    End With

    ' 複写領域を溜めたRangeオブジェクトを
    ' クリップボードにコピー
    rgSel.Copy

    ' Workbookを追加
    Set wbNew = Workbooks.Add

    ' 追加したWorkbookをアクティブにする
    wbNew.Activate

    ' アクティブシートにクリップボードの内容を貼り付ける
    ActiveSheet.Paste

End Sub

◆実行結果

「検索」ボタンを押下します。

検索対象の列を入力します。 今回は列C(「状態」の列)を検索したいので、「C」と入力します。

検索条件を「検討中」と入力します。

列C に「検討中」が含まれる行が新しいブックにコピーされました!

▲ PageTop  ■ Home


Copyright (C) 2012 ymlib.com