Findメソッドで空白セルがヒットした場合空白セルをコピペしたい

Question

"組織図"シートから"Sheet1"シートに社員情報を転記するマクロを作成しています。
"課検索"マクロと”メンバー検索”マクロを作成しましたが、
課を"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:=xlPart)
    
    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(Rows.Count, 1).End(xlUp).Offset(1, 0).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
    
 End If
 
 End Sub

コード
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.Offset(0, 1) '最初に見つかったセルを格納しておく
    
    
    Do
              If InStr(ResultRange.Value, "課長") = 0 And InStr(ResultRange.Value, "課担当") = 0 Then
         ResultRange.Offset(0, 1).Copy
             Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
         
         Application.CutCopyMode = False
        
        
        i = i + 1
        
        End If
     
          Set ResultRange = SearchRange.FindNext(After:=ResultRange) '次の検索セルを指定する
          
        
        
         If ResultRange.Offset(0, 1).Address = StartRange.Address Then '見つかったセルが最初のセルか判定
        
            Exit Do '同じ場合はループを離脱
            
        
        End If
        
   Loop
    
 End If
 
 End Sub

Comments

[Usirow]

ぱっと見る限り一つにまとめるだけで解決しそうだと思うんですけど、わざわざ課検索とメンバー検索とで二つに分けているのには何か理由があるんでしょうか？

[GKHHKJ]

マクロ初心者なもので、まとめ方がわからないんです…
よろしければ教えていただけますと幸いです

Answer 1

課のメンバーがいないケースがあるようですが、メンバーが２名以上のケースはないのですか？

|A|B|C|D|E|F|G|
|:--|:--|:--|:--|:--|
||||
|すぐやる課|メンバー）山田||まあいい課|メンバー）白石||
|課長)田中|||課長）今野|メンバー）秋元||
||||
||||
||||

---

＜追記＞
多分こんな感じだと思う。

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


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

    KeyItem = "*課"
    Set ResultRange = SearchRange.Find(What:=KeyItem, Lookat:=xlWhole)
    If ResultRange Is Nothing Then Exit Sub
    Set StartRange = ResultRange '最初に見つかったセルを格納しておく
    
    
    Dim ws As Worksheet, outRange As Range
    Set ws = Worksheets("Sheet1")
    Set outRange = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0)
    
    
    Do
        Dim kacho As Range, member As Range
        Set kacho = ResultRange.Offset(1, 0)
        Set member = ResultRange.Offset(0, 1)
        i = 0
        
        outRange.Value = kacho.Value
        If member.Value = "" Then
            Set outRange = outRange.Offset(1, 0)
        Else
            Do While member.Offset(i, 0).Value <> ""
                outRange.Offset(i, 1).Value = member.Offset(i, 0).Value
                i = i + 1
            Loop
            Set outRange = outRange.Offset(i, 0)
        End If

        Set ResultRange = SearchRange.FindNext(After:=ResultRange) '次の検索セルを指定する
        
        If ResultRange.Address = StartRange.Address Then Exit Do '見つかったセルが最初のセルか判定 同じ場合はループを離脱

    Loop

 End Sub

Comments

[GKHHKJ]

メンバー複数います！

[jinoji]

メンバーが０名のとき、１名のとき、２名のとき、３名のとき、など
それぞれの場合にどういう出力にしたいのかを、きちんとイメージしておいた方がいいと思います。
こんな感じなのでしょうか。
｜田中｜山田｜　　・・・１名
｜伊藤｜＿＿｜　　・・・０名
｜今野｜白石｜　　・・・２名
｜＿＿｜秋元｜

[GKHHKJ]

そういう感じです！

Answer 2

見た感じではこういうことだと思いました。

'前略
Do
    If InStr(ResultRange.Value, "課長") = 0 And InStr(ResultRange.Value, "課担当") = 0 Then

        ResultRange.Copy
        Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)

        ResultRange.Offset(0, 1).Copy
        Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).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

Comments

[GKHHKJ]

できませんでした…