Looping

Hi,

Rather than repeating the below 18 times how do I make this more efficient,
many thanks for help

Teresa


Sub coi()
Set fin = Application.Workbooks.Open("C:\My Documents\Business
Plans\Team.xls")

lastrow = Cells(Rows.Count, 3).End(xlUp).Row
j = 18
For i = 3 To lastrow
If Cells(i, 4) = "Hudson" Then
Cells(i, 4).EntireRow.Copy Destination:=fin.Worksheets("Hudson").Cells(j, 1)
j = j + 1
End If
Next

j = 18
For i = 3 To lastrow
If Cells(i, 4) = "John" Then
Cells(i, 4).EntireRow.Copy Destination:=fin.Worksheets("John").Cells(j, 1)
j = j + 1
End If
Next

End Sub

One way:

Public Sub coi()
Dim fin As Workbook
Dim vArr As Variant
Dim rCell As Range
Dim rDest As Range
Dim i As Long

Set fin = Application.Workbooks.Open( _
"C:\My Documents\Business Plans\Team.xls")
vArr = Array("Hudson", "John")
For Each rCell In Range("D1:D" & _
Range("D" & Rows.Count).End(xlUp).Row)
With rCell
For i = LBound(vArr) To UBound(vArr)
If .Value = vArr(i) Then
Set rDest = fin.Worksheets(vArr(i)).Cells( _
Rows.Count, 1).End(xlUp).Offset(1, 0)
If rDest.Row < 18 Then _
Set rDest = rDest.Offset(18 - rDest.Row, 0)
.EntireRow.Copy Destination:=rDest
Exit For
End If
Next i
End With
Next rCell
End Sub

Add 16 items to the vArr = Array(... line



In article <[email protected]>,
teresa <[email protected]> wrote:

> Hi,
>
> Rather than repeating the below 18 times how do I make this more efficient,
> many thanks for help
>
> Teresa
>
>
> Sub coi()
> Set fin = Application.Workbooks.Open("C:\My Documents\Business
> Plans\Team.xls")
>
> lastrow = Cells(Rows.Count, 3).End(xlUp).Row
> j = 18
> For i = 3 To lastrow
> If Cells(i, 4) = "Hudson" Then
> Cells(i, 4).EntireRow.Copy Destination:=fin.Worksheets("Hudson").Cells(j, 1)
> j = j + 1
> End If
> Next
>
> j = 18
> For i = 3 To lastrow
> If Cells(i, 4) = "John" Then
> Cells(i, 4).EntireRow.Copy Destination:=fin.Worksheets("John").Cells(j, 1)
> j = j + 1
> End If
> Next
>
> End Sub
>

This is great, thks so much - Ive tried to add another condition so that if
the cell in D Col doesn't equal an entry within the array, but the entry in
G Col equals "CC" then the line will go the "Other" worksheet, doesnt quite
work though:

Public Sub coiD()
Dim fin As Workbook
Dim vArr As Variant
Dim rCell As Range
Dim rDest As Range
Dim i As Long

Set fin = Application.Workbooks.Open( _
"C:\My Documents\Business Plans\Team.xls")
vArr = Array("Hudson", "John", "Jim")
For Each rCell In Range("D1:D" & _
Range("D" & Rows.Count).End(xlUp).Row)
With rCell
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)
'If rDest.Row < 18 Then _
' Set rDest = rDest.Offset(18 - rDest.Row, 0)
.EntireRow.Copy Destination:=rDest
Else If rCell.Offset(0,3)= "CC" Then
rCell.EntireRow.Copy
Destination:=fin.Worksheets("Other").Cells( _
25, 1).End(xlUp).Offset(1, 0)

Exit For
End If
Next i
End With
Next rCell


"JE McGimpsey" wrote:

> One way:
>
> Public Sub coi()
> Dim fin As Workbook
> Dim vArr As Variant
> Dim rCell As Range
> Dim rDest As Range
> Dim i As Long
>
> Set fin = Application.Workbooks.Open( _
> "C:\My Documents\Business Plans\Team.xls")
> vArr = Array("Hudson", "John")
> For Each rCell In Range("D1:D" & _
> Range("D" & Rows.Count).End(xlUp).Row)
> With rCell
> For i = LBound(vArr) To UBound(vArr)
> If .Value = vArr(i) Then
> Set rDest = fin.Worksheets(vArr(i)).Cells( _
> Rows.Count, 1).End(xlUp).Offset(1, 0)
> If rDest.Row < 18 Then _
> Set rDest = rDest.Offset(18 - rDest.Row, 0)
> .EntireRow.Copy Destination:=rDest
> Exit For
> End If
> Next i
> End With
> Next rCell
> End Sub
>
> Add 16 items to the vArr = Array(... line
>
>
>
> In article <[email protected]>,
> teresa <[email protected]> wrote:
>
> > Hi,
> >
> > Rather than repeating the below 18 times how do I make this more efficient,
> > many thanks for help
> >
> > Teresa
> >
> >
> > Sub coi()
> > Set fin = Application.Workbooks.Open("C:\My Documents\Business
> > Plans\Team.xls")
> >
> > lastrow = Cells(Rows.Count, 3).End(xlUp).Row
> > j = 18
> > For i = 3 To lastrow
> > If Cells(i, 4) = "Hudson" Then
> > Cells(i, 4).EntireRow.Copy Destination:=fin.Worksheets("Hudson").Cells(j, 1)
> > j = j + 1
> > End If
> > Next
> >
> > j = 18
> > For i = 3 To lastrow
> > If Cells(i, 4) = "John" Then
> > Cells(i, 4).EntireRow.Copy Destination:=fin.Worksheets("John").Cells(j, 1)
> > j = j + 1
> > End If
> > Next
> >
> > End Sub
> >
>