Too Many/No lInes are copied over

[teresa]

Background:

I have raw data in the form of a Job List, this is where the code is written

The code below is quite close to what I want, however:

'2) If Cell equals Team CB's Client then line is copied to appropriate
w/sheet:
the line is copied over 3 times

'4)If Cell equals Team MS's Client then line is copied to appropriate w/sheet:
the line isn't copied over at all

Many Thanks

Public Sub coi()
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

'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", "HSB", "C&W")
vArr2 = Array("ACCENT", "AMEX", "SHELL")


For Each rCell In Range("D1" & _
Range("D" & Rows.Count).End(xlUp).Row)
With rCell
For i = LBound(vArr) To UBound(vArr)
For j = LBound(vArr2) To UBound(vArr2)
'2) If Cell equals Team CB's Client then line is copied to
appropriate w/sheet
If .Value = vArr(i) Then
Set rDest = fin.Worksheets(vArr(i)).Cells( _
25, 1).End(xlUp).Offset(1, 0)
.EntireRow.Copy Destination:=rDest
'3) If Client is not designated Client but Executive is CB copies
to "Other"
ElseIf .Offset(0, 3).Value = "CB" Then
..EntireRow.Copy _
Destination:=fin.Worksheets("OTHER").Cells(25,
1).End(xlUp).Offset(1, 0)

'4)If Cell equals Team MS's Client then line is copied to
appropriate w/sheet
If .Value = vArr2(j) Then
Set sDest = fin2.Worksheets(vArr2(j)).Cells( _
25, 1).End(xlUp).Offset(1, 0)
.EntireRow.Copy Destination:=sDest
Exit For

End If
End If
Next j
Next i
End With
Next rCell
End Sub

 

[K Dales]

I am trying to follow your code and so perhaps I don't understand what you
are trying to do, but why are you looping within a loop? You are using i to
step through the first array, and then inside that loop you are using j to
loop through the second array. So for each i (CB) you are going through the
j loop three times, explaining why it would copy three times. And then, your
If statement for looking for MS's clients is nested inside the If looking for
CB's clients. So if the test for CB's clients is not true (which it would
have to be, if it was MS) it never makes it to the test for MS. So that is
probably why it never copies for MS's clients. You will need to separate out
the tests in a different way.

I think this might work:
Dim FoundClient as Boolean

FoundClient = False
With rCell

' Check for Team CB's client:
For i = LBound(vArr) To UBound(vArr)
If rCell.Value = vArr(i) Then
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

' 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
Next j

' If neither was found, then check your 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