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

Looping
 

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 ,
teresa 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

Looping
 

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 ,
teresa 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