検索結果を含む行を別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