検索した文字から上のセルを検索して一致した最初の値を返してほしい

Question

以下のようなシートがあります
”組織図”シート
(列　不特定
営業部
部付)田中太郎
部付)鈴木次郎
部付)佐藤三郎
部付)山田四郎

↑のシートから↓のシートのように転記したいです。

”Sheet1”
A列　　　　　　　　B列
営業部　　　　　　部付)田中太郎
営業部　　　　　　部付)鈴木次郎
営業部　　　　　　部付)佐藤三郎
営業部　　　　　　部付)山田四郎

方法として、
"部付）"をFIND関数で検索、
B列にそれを転記
A列にその単語と同じ列で、その単語の上の行の中で“*部”検索して、
一番最初の値を返す

こんなマクロはどう組めばよろしいのでしょうか。

 Sub 部付）検索()
    
    Dim SearchRange As Range '検索範囲格納
    Dim ResultRange As Range '検索結果格納
    Dim StartRange  As Range '検索行格納
    Dim KeyItem     As String
       
    
    Set SearchRange = Worksheets("組織図").Range("A:Z")   '検索したいデータ範囲
    
    KeyItem = " 部付）"
    
    Set ResultRange = SearchRange.Find(KeyItem, Lookat:=xlPart)
    
    If Not ResultRange Is Nothing Then
         Set StartRange = ResultRange '最初に見つかったセルを格納しておく
    
    
    Do
              If InStr(ResultRange.Value, "プロジェクトチーム") = 0  Then
          ResultRange.Copy
          Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
         
         Application.CutCopyMode = False
        
    
        
        End If
     
          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

相談者様のVBAコードを見ると、部付）から始まるセルを逐一検索し、1個ずつコピーしています。
CurrentRegionとResizeを活用すると、スッキリとしたコードになります。
部門セルC1
開始セルC2
社員数4
社員セルC2:C5
を前提に、以下のコードを解説します。

Option Explicit

Sub 社員転記()
    Dim startRange As Range               ' "部付）"と書いてある最上位セル（以下開始セル）
    Dim memberRange As Range              ' 全社員が入っているセル（以下社員セル）
    Dim member As Long                    ' 社員数
    Dim department As String              ' 部門名
    
    ' "部付）"を含む文字列をA1セルを開始位置として部分一致検索
    Set startRange = Cells.Find("部付）", lookat:=xlPart, after:=Range("A1"))
    If startRange Is Nothing Then         ' 見つからなかったらマクロ終了
        Exit Sub
    End If

    ' 開始セルの一つ上のセルに入っている部門名を取り出す
    department = startRange.Offset(-1, 0).Value

    ' 開始セルを含む領域の行数-1(部門名のセルを除外)が社員数
    member = startRange.CurrentRegion.Rows.Count - 1

    '開始セルを社員数分だけ行方向に拡張したセル範囲が社員セル
    Set memberRange = startRange.Resize(member, 1)                                 
    
    With Worksheets("sheet1")
        memberRange.Copy .Range("B1")                 ' 社員セルを"B1"から始まるセルに転記
        .Range("A1").Resize(member, 1) = department   ' 部門名を"A1"から始まるセルに転記
    End With
End Sub

以下、重要な部分の説明

Find

• 全範囲のセルはcellsとすればOK
• 部分一致検索はLookat:=xlPart
• 検索開始位置をAfter:="A1"とすれば、確実に一番上の社員を見つけられる。
• この結果、図のC2セルが見つかる。

Offset

• 開始セルから(行, 列)だけ移動したセルはstartRange.Offset(行, 列)で取得できる。

ここでは(行, 列)　= (-1, 0)

CurrentRegion

• CurrentRegionを使うと、該当セルを含む一続きの領域のセル範囲が得られる。

図の例ではRange("C2").CurrentRagionはRange("C1:C5")を表す。

• 求めたセル範囲の行数-1で社員数が得られる（-1は部門名の行数を省くため）。

Resize

• Resizeを使うと、セルの範囲を拡張できる。

図の例ではRange("C2").Resize(4, 1)でRange("C2:C5")を表す。

• startRange.Resize(member, 1)で社員セル範囲が得られる。

あとは社員セルをSheet1のB1から始まるセルにコピーし、部門名をSheet1のA1から始まるセルにコピーする。

以上が回答となります。
お役に立てれば幸いです。

Answer 2

こんな感じでどうでしょうか。

Dim bu
bu = ResultRange.End(xlUp).Value