VBAで検索の絞り方を教えてください

Question

'組織図'シートから'部'署を検索して'Sheet1'に転記するマクロを組んだのですが、
部長)田中太郎　部付)山田花子　のような関係ないセルまで引っ張ってきてしまい、
困っております。

「部長」「部付」を除外して検索する方法、
部署のセルは上下左右実線の罫線で囲まれているため、
それらのみに絞って検索する方法、
「部長」「部長」の行を後から削除する方法などあれば、
教えて頂けないでしょうか。

Sub 部検索()

Dim SearchRange As Range '検索範囲格納
Dim ResultRange As Range '検索結果格納
Dim StartRange  As Range '検索行格納
Dim KeyItem     As String
Dim MsgStr      As String
Dim i           As Long

   i = 1


Set SearchRange = Worksheets("組織図").Range("A:Z")   '検索したいデータ範囲

KeyItem = "部"

Set ResultRange = SearchRange.Find(KeyItem, LookAt:=xlPart)

If Not ResultRange Is Nothing Then
     Set StartRange = ResultRange '最初に見つかったセルを格納しておく


Do
      ResultRange.Copy Worksheets("Sheet1").Cells(i, "A")
     
     Application.CutCopyMode = False
    
    
    i = i + 1
    
    
 
      Set ResultRange = SearchRange.FindNext(After:=ResultRange) '次の検索セルを指定する
      
    
    
    If ResultRange.Address = StartRange.Address Then '見つかったセルが最初のセルか判定
    
        Exit Do '同じ場合はループを離脱
        
    
    End If
    
Loop While StartRange <> ResultRange

End If

End Sub

Answer 1

実際にどんなシートか分かりにくいので最も簡単な方法を。
「部長」や「部付」がを除外したいのであれば検索後のセルの値を見るのが手っ取り早いです。

If InStr(ResultRange.Value, "部長") = 0 And InStr(ResultRange.Value, "部付") = 0 Then
    '該当したセルの値に"部長"or"部付"が含まれていない場合に転記する
    ResultRange.Copy Worksheets("Sheet1").Cells(i, "A")
    Application.CutCopyMode = False
    i = i + 1
End If

Comments

[GKHHKJ]

こちらもできました！ありがとうございました。

Answer 2

もし「営業部」「総務部」のような最後が「部」で終わるセルを探すのであれば、

KeyItem = "*部"
Set ResultRange = SearchRange.Find(KeyItem, LookAt:=xlWhole)

みたいにするのがよいのでは。

Comments

[GKHHKJ]

できました！ありがとうございました。