Not going through all Conditions
 

The following code should:
1) look through each D Col cell
2) If it is a CB client dump it into CB's workbook, if not..
3) ..and if it is a MS Client, dump it into MS ' s workbook
4)If neither 2) and 3) but executive is CB dumps it into CB's workbook

My problem is that it is not going through 3) and 4)

Many Thanks

Public Sub coi3()

Dim fin As Workbook
Dim fin2 As Workbook
Dim vArr As Variant
Dim vArr2 As Variant
Dim rCell As Range
Dim rDest As Range
Dim sDest As Range
Dim i As Long
Dim j As Long
Dim FoundClient As Boolean

'1)Opens Team CB and Team MS Workbooks,define arrays in line with Client Lists
Set fin = Application.Workbooks.Open( _
"C:\My Documents\Business Plans\TeamCB.xls")
Set fin2 = Application.Workbooks.Open( _
"C:\My Documents\Business Plans\TeamMS.xls")
vArr = Array("Hudson", "HSBC", "C&W")
vArr2 = Array("ACCENT", "AMEX", "SHELL")

FoundClient = False
For Each rCell In Range("D1:D" & _
Range("D" & Rows.Count).End(xlUp).Row)
With rCell
'2) Check for Team CB's client:
For i = LBound(vArr) To UBound(vArr)
If .Value = vArr(i) Then
Set rDest = fin.Worksheets(vArr(i)).Cells( _
25, 1).End(xlUp).Offset(1, 0)
..EntireRow.Copy Destination:=rDest
FoundClient = True
End If
Next i



' If CB's client can skip, otherwise:
If Not FoundClient Then
End If

' 3)Check for Team MS's client:
For j = LBound(vArr2) To UBound(vArr2)
If rCell.Value = vArr2(j) Then
If .Value = vArr(j) Then
Set sDest = fin2.Worksheets(vArr2(j)).Cells( _
25, 1).End(xlUp).Offset(1, 0)
..EntireRow.Copy Destination:=sDest
FoundClient = True
End If
End If
Next j

' 4)If neither was found, then check other condition (executive is CB):
If Not FoundClient Then
If .Offset(0, 3).Value = "CB" Then
..EntireRow.Copy _
Destination:=fin.Worksheets("OTHER").Cells(25, 1).End(xlUp).Offset(1, 0)
End If
End If

End With
Next rCell
End Sub

Not going through all Conditions
 

If my read is correct then the error is the following two block of code:
' If CB's client can skip, otherwise:
If Not FoundClient Then
End If

For j = LBound(vArr2) To UBound(vArr2)
If rCell.Value = vArr2(j) Then
If .Value = vArr(j) Then
Set sDest = fin2.Worksheets(vArr2(j)).Cells( _
25, 1).End(xlUp).Offset(1, 0)
.EntireRow.Copy Destination:=sDest
FoundClient = True
End If
End If
Next j

Suggested is that you check if substituting the following works. Note the
removal of the inner nested If/End If statement requiring that rCell.Value
simultaneously equal vArr2(j) and vArr(j):

If Not FoundClient Then
' 3) Check for Team MS's client:
For j = LBound(vArr2) To UBound(vArr2)
If .Value = vArr2(j) Then
Set sDest = fin2.Worksheets(vArr2(j)).Cells( _
25, 1).End(xlUp).Offset(1, 0)
.EntireRow.Copy Destination:=sDest
FoundClient = True
End If
Next j
End If

Regards,
Greg