Find,FindNextで検索したセルの1つ下のセルをコピペした隣のセルに貼り付けたい

”組織図”シートから部署を検索して”Sheet1”シートのA列に貼り付けるマクロを作ったのですが、
元シートの部署のセルの1つ下のセルを転記先のB列に貼り付けるマクロはどう書けばいいのでしょうか。

”組織図”シート
A~Z列
営業部
部長）田中太郎

人事部
部長）山田花子

”Sheet1”シート　
A列 B列
営業部部長）田中太郎
人事部部長）山田花子

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:=xlWhole)

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


Do
          If InStr(ResultRange.Value, "法務部") = 0 And InStr(ResultRange.Value, "メディア情報事業部") = 0 Then
      ResultRange.Copy
      Worksheets("Sheet1").Cells(i, "D").PasteSpecial (xlPasteValues)
     
     Application.CutCopyMode = False
    
    
    i = i + 1
    
    End If
 
      Set ResultRange = SearchRange.FindNext(After:=ResultRange) '次の検索セルを指定する
      
    
    
    If ResultRange.Address = StartRange.Address Then '見つかったセルが最初のセルか判定
    
        Exit Do '同じ場合はループを離脱
        
    
    End If
    
Loop While StartRange <> ResultRange