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