No9です、
実行するたびに記号列で空白になった部分もふくめてずれていくので、記号列は空白セルを無視するように変更しました。
Sub Example()
Dim MyArrayB As Variant, MyArrayC As Variant, Myarr As Variant
Dim SearchStr As String
Dim i As Long, j As Long, k As Long, l As Long
MyArrayB = Range(Cells(3, "B"), Cells(Rows.Count, "B").End(xlUp))
MyArrayC = Range(Cells(3, "C"), Cells(Rows.Count, "C").End(xlUp))
SearchStr = "りんご"
j = 1: k = 0
l = WorksheetFunction.CountIf(Range(Cells(3, "C"), Cells(Rows.Count, "C").End(xlUp)), SearchStr)
ReDim Myarr(UBound(MyArrayC) + l, 1)
For i = 1 To UBound(Myarr)
If MyArrayB(j, 1) <> "" Then
If UBound(MyArrayC) >= i Then
If MyArrayC(i, 1) <> SearchStr Then
Myarr(k, 0) = MyArrayB(j, 1)
j = j + 1
If j > UBound(MyArrayB) Then
j = 1
End If
Else
Myarr(k, 0) = ""
End If
Else
Myarr(k, 0) = MyArrayB(j, 1)
j = j + 1
If j > UBound(MyArrayB) Then
j = 1
End If
End If
k = k + 1
Else
j = j + 1
i = i - 1
End If
Next
Range(Cells(3, "B"), Cells(UBound(Myarr) + 3, "B")) = Myarr
End Sub