Help with my VBA

[James]

I have the following code and what it does is find the name "James" in this
example and copies all the information that is associated on that row and
places it on Sheet2.

I need this code to be a little more flexiable, but cannot figure out how to
have it look through a list of names that is on Sheet3 in column A starting
in row1. I will have anywhere between 10 to 20 names and would like this
Macro to run through that list of names that is on Sheet3. I hope I have
explained this well enough, if not let me know

Sub CopyNames()
'col Name of the active worksheet (source sheet) to cols
'A to Z of Sheet2 (destination sheet)
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long
sCount = 0
dRow = 1

For sRow = 1 To Range("D65536").End(xlUp).Row
'use pattern matching to find "Name" anywhere in cell
If Cells(sRow, "A") Like "*James*" Then
sCount = sCount + 1
dRow = dRow + 1
'copy cols A to Z
Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A")
Cells(sRow, "B").Copy Destination:=DestSheet.Cells(dRow, "B")
Cells(sRow, "C").Copy Destination:=DestSheet.Cells(dRow, "C")
Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "D")
Cells(sRow, "E").Copy Destination:=DestSheet.Cells(dRow, "F")
Cells(sRow, "G").Copy Destination:=DestSheet.Cells(dRow, "G")
Cells(sRow, "H").Copy Destination:=DestSheet.Cells(dRow, "H")
Cells(sRow, "I").Copy Destination:=DestSheet.Cells(dRow, "I")
End If
Next sRow

MsgBox sCount & "rows copied", vbInformation, "Transfer Done"

End Sub

Thank you, as always

 

[Jim Thomlinson]

The easiest thing to do is to add a parameter to the procedure which is the
name you are looking for. Then call the procedure repeatedly with different
names...

Sub CopyAllNames
call Sub CopyNames("James")
call Sub CopyNames("John")
end sub

public sub CopyNames(byval strName as string)
'...
If Cells(sRow, "A") Like "*" & strname & "*" Then
'...
end sub

 

[James]

Jim,
Thanks for the assistance, your idea works and it will do for now. However
I was trying to come up with something that I do not have to type in, I tried
a few other things all with no much success but your idea does work but will
have to change every time I get a new list of names.

Thanks

 

[Jim Thomlinson]

Put your list of names in a sheet and itterate through the cells picking up
the names something like this. It assumes the list of names is in sheet1
cells A2:A??

Sub CopyAllNames
dim rng as range
dim rngNames as range

with sheets("Sheet1")
set rngnames = .range(.range("A2"), .cells(rows.count, "A").end(xlup))
end with
for each rng in rngnames
call Sub CopyNames(rng.value)
end sub

 

[James]

Jim,

First thanks for looking at my code. I tries inserting your code as well
but I cannot get it to work. Can you take a look at it and let me know what
is wrong with it.

Here is what I have now

Sub CopyAllNames()
Dim rng As Range
Dim rngNames As Range

With Sheets("Sheet3")
Set rngNames = .Range(.Range("A2"), .Cells(Rows.Count, "A").End(xlUp))
End With
For Each rng In rngNames
call Sub CopyNames(rng.value)
End Sub


Sub CopyNames()
'col Name of the active worksheet (source sheet) to cols
'A to Z of Sheet2 (destination sheet)
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet2")

Dim sRow As Long 'row index on source worksheet
Dim dRow As Long 'row index on destination worksheet
Dim sCount As Long

sCount = 0
dRow = 1

For sRow = 1 To Range("D65536").End(xlUp).Row
'use pattern matching to find "Name" anywhere in cell


If Cells(sRow, "A") Like "*" & strname & "*" Then
'If Cells(sRow, "A") Like "*James*" Then

sCount = sCount + 1
dRow = dRow + 1
'copy cols A to Z
Cells(sRow, "A").Copy Destination:=DestSheet.Cells(dRow, "A")
Cells(sRow, "B").Copy Destination:=DestSheet.Cells(dRow, "B")
Cells(sRow, "C").Copy Destination:=DestSheet.Cells(dRow, "C")
Cells(sRow, "D").Copy Destination:=DestSheet.Cells(dRow, "D")
Cells(sRow, "E").Copy Destination:=DestSheet.Cells(dRow, "F")
Cells(sRow, "G").Copy Destination:=DestSheet.Cells(dRow, "G")
Cells(sRow, "H").Copy Destination:=DestSheet.Cells(dRow, "H")
Cells(sRow, "I").Copy Destination:=DestSheet.Cells(dRow, "I")
End If
Next sRow

MsgBox sCount & " rows copied", vbInformation, "Transfer Done"

End Sub

Thanks

 

[Jim Thomlinson]

Oops.. Remove the word sub...

Sub CopyAllNames
dim rng as range
dim rngNames as range

with sheets("Sheet1")
set rngnames = .range(.range("A2"), .cells(rows.count, "A").end(xlup))
end with
for each rng in rngnames
call CopyNames(rng.value)
end sub