Match and Copy

[Chris]

Hi there,

I'm pretty new with VBA scripting. But what i want is the following.
I have 2 sheets. in Sheet 1 I have som1 names of som different
companies at the A column. These companies are also presented in sheet
2 at the C column. In sheet 2 in Column A are the names of the
employee's. What i want is a VBA script that looks in column A of
sheet 1 and search for the same companie name in sheet 2 at column C.
If there is a match he should copy the names of the employee's to
sheet 1 behind the company name in the G column. The problem is that
there are som employees who work in 2 companies. These companies are
in the same cell separated by a ';' . Here a little example.

sheet 1:

A B C D E F G

1 Farm

2 Electro

3 ICT

4 Mechanic

In G1 should come all employees of farm in one cell, seperated by a
';' .


Sheet 2

A B C

1 Piet ICT
2 Henk Mechanic
3 Klaas Farm;Electro

Hope it is clear. If you come with a VBA script, please give a
explanation so i can learn something.
Sorry for my bad English.

Chris

 

[Tom Ogilvy]

Building off some code just posted by Dave Peterson:

Option Explicit
Sub testme()

Dim FoundCell As Range
Dim myRng As Range
Dim whatToFind As String
Dim wks As Worksheet
Dim wks2 as Worksheet
Dim rng1 as Range, cell as Range, rng2 as Range
Dim fAddr as String
Dim sStr as String

Set wks2 = worksheets("Sheet2")
set rng2 =
wks2.Range(wks2.Cells(1,"C"),wks2.Cells(1,"C").End(xldown)(2))
Set wks = Worksheets("sheet1")
set rng1 = wks.Range(wks.Cells(1,1),wks.Cells(1,1).End(xldown))
for each cell in rng1
sStr = ""
fAddr = ""
whatToFind = cell.Value

Set FoundCell = rng2.Cells.Find(what:=whatToFind, _
after:=rng2(rng2.count), LookIn:=xlValues, lookat:=xlPart, _
searchorder:=xlByRows, searchdirection:=xlNext, _
MatchCase:=False)


If not FoundCell Is Nothing Then
fAddr = FoundCell.Address
do
sStr = sStr & FoundCell.offset(0,-2).Value & ";"
set FoundCell = rng2.FindNext(FoundCell)
Loop while not FoundCell.Address = fAddr
cell.offset(0,6).Value = Left(sStr,len(sStr)-1)
End If
Next cell

End Sub

 

[Seiya]

Hi,
try the code

Sub test()
Dim r As Range, txt, ws1 As Worksheet, ws2 As Worksheet
Dim LookUpCell As Range, x
Set ws1 = Sheets("sheet1"): Set ws2 = Sheets("sheet2")
With ws2
For Each r In .Range("b1", .Range("b65536").End(xlUp))
If Not IsEmpty(r) Then
If InStr(r, ";") = 0 Then
Set LookUpCell = ws1.Range("a:a").Find(what:=r.Value,
lookat:=xlWhole)
LookUpCell.Offset(, 1) = r.Offset(, -1).Value
Else
txt = Split(Replace(r, " ", ""), ";")
For Each x In txt
Set LookUpCell = ws1.Range("a:a").Find(what:=x,
lookat:=xlWhole)
LookUpCell.Offset(, 1) = r.Offset(, -1).Value
Next
End If
End If
Next
Set ws1 = Nothing: Set ws2 = Nothing: Erase txt
End With

 

[Chris]

Thanks for helping me out...
But i have a little problem. I have copied the script (Seiya's
Script), but when i run it he gives a error. 'Error 9 subscript is out
of reach' (don't know the exact translation, but hope you'll
understand the problem)
Thanks again, and hope you have a solution.

 

[Seiya]

Hi, Kris

assumed:

Sheet1: you have Comapny in col.A
Sheet2: you have Person in charge in Col.A and Company in Col.B
and the company names in each sheet MUST be identical.
if you run the code with the data as above, it should work.

Sub test()
Dim r As Range, txt, ws1 As Worksheet, ws2 As Worksheet
Dim LookUpCell As Range, x
Set ws1 = Sheets("sheet1"): Set ws2 = Sheets("sheet2")
With ws2
For Each r In .Range("b1", .Range("b65536").End(xlUp))
If Not IsEmpty(r) Then
If InStr(r, ";") = 0 Then
Set LookUpCell = ws1.Range("a:a").Find(what:=r.Value,
lookat:=xlWhole)
If Not LookUpCell Is Nothing Then
LookUpCell.Offset(, 1) = r.Offset(, -1).Value
End If
Else
txt = Split(Replace(r, " ", ""), ";")
For Each x In txt
Set LookUpCell = ws1.Range("a:a").Find(what:=x,
lookat:=xlWhole)
If Not LookUpCell Is Nothing Then
LookUpCell.Offset(, 1) = r.Offset(,
-1).Value
End If
Next
End If
End If
Next
Set ws1 = Nothing: Set ws2 = Nothing: Erase txt
End With
End Sub

 

[Tom Ogilvy]

If your sheets actually have a space in the name you might try: (otherwise
adjust the sheet names to match sheet names - the columns referenced match
what you describe and the code was successfully tested).

Option Explicit
Sub testme()

Dim FoundCell As Range
Dim myRng As Range
Dim whatToFind As String
Dim wks As Worksheet
Dim wks2 as Worksheet
Dim rng1 as Range, cell as Range, rng2 as Range
Dim fAddr as String
Dim sStr as String

Set wks2 = worksheets("Sheet 2")
set rng2 = _
wks2.Range(wks2.Cells(1,"C"), _
wks2.Cells(1,"C").End(xldown)(2))
Set wks = Worksheets("sheet 1")
set rng1 = wks.Range(wks.Cells(1,1), _
wks.Cells(1,1).End(xldown))
for each cell in rng1
sStr = ""
fAddr = ""
whatToFind = cell.Value

Set FoundCell = rng2.Cells.Find(what:=whatToFind, _
after:=rng2(rng2.count), LookIn:=xlValues, lookat:=xlPart, _
searchorder:=xlByRows, searchdirection:=xlNext, _
MatchCase:=False)


If not FoundCell Is Nothing Then
fAddr = FoundCell.Address
do
sStr = sStr & FoundCell.offset(0,-2).Value & ";"
set FoundCell = rng2.FindNext(FoundCell)
Loop while not FoundCell.Address = fAddr
cell.offset(0,6).Value = Left(sStr,len(sStr)-1)
End If
Next cell

End Sub

--
Regards,
Tom Ogilvy

 

[Chris]

Thanks for all your help. I get an runtime error now, but i think i
know why. Cause not every cell in the row of company names is
filled.... i'll try to figure that out myself. sorry to say this but
maybe i'll don't use the script at all, cause the plans here are a
litlle bit changed.
But thanks anyway.... for the learning process