Match and Copy to array

[Chris]

I have a question about som things.

Earlier i get this script, and it works fine.

Sub test()
Dim r As Range, txt, ws1 As Worksheet, ws2 As Worksheet
Dim LookUpCell As Range, x
Set ws1 = Sheets("FireWall Rules"): Set ws2 = Sheets("LDAP")
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

This script looks in Column A of sheet1 for a certain company name,
search for the same company name in column B of sheet2, and copy the
column A value of the same row to sheet1 Column B. It works perfect.

Here a little example of sheet 2

A B C D E

1 employee Company

2 Steve Sony

3 John Philips

4 Chris Sony

5 Steven Sony

6 Rutger Philips



As you can see there are more employees at one company (company names
are also represented in column A of sheet but without dupes). I want
the empleyees in array, cause these have to be matched with my third
sheet.... I don't know how to do this any suggestions?

 

[Tom Ogilvy]

How does it work perfect if it doesn't do what you want?

What does this do that doesn't answer what you want to do.

As I recall, I provided code that does what you ask, but you chose to ignore
it. Perhaps you should look back at your original post and say why that
doesn't work.

 

[Chris]

Just like i said in the earlier thread, i changed the plans a little
bit.
Earlier i would look in sheet1 for a employee name and search for the
same name in sheet2. If he found that name he should copy the company
name to sheet1. And some employee's are working at two or three (up to
15) company's, and the company names are seperated with a ';'.

But the plan is changed to....
I made a sub who copies all the company names to sheet1 (The sheet
numbers are a little shuffled also so maybe they are different with
the first plan) without dupes.
He have to look now at the company name and look for that name in
sheet 2 and copy the employee name to an array or somthing. But there
are several rows with the same company. Because every employee has his
own row.
Than plan is if he has all the employee names who are in a certain
company, he have to match that names with an administrative sheet (the
third sheet)to look if the admistation is uptodate.
My problem now is that the code i get earlier (who is above also)
looks for the company name if he found it he copy's the employee name.
If he found one he stop searching. He have to look further down to the
sheet (+/- 12000 rows) and copy all the employee names who has that
certain company name in there row.
I dont know exactly if this is a smart plan cause maybe i have a
problem later when he have to macht the employee names with the third
sheet.
But for now he has to match the company names and get all the employee
names. There are about 40 company's and 12000 employees. Can he make a
array whith the employee names and the company names matched and the
lookup that names in the third sheet.

I hope i'am clear now, if not i'm sorry and just ignore this message
.

 

[Tom Ogilvy]

If that code does what you want and you just want to keep searching, then
this should work:

Sub test()
Dim r As Range, txt, ws1 As Worksheet, ws2 As Worksheet
Dim LookUpCell As Range, x
Set ws1 = Sheets("FireWall Rules"): Set ws2 = Sheets("LDAP")
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
fAddr = LookupCell.Address
do
LookUpCell.Offset(, 1) = LookUpCell.Offset(,1) & _
r.Offset(, -1).Value & ";"
Set LookUpCell = ws1.Range("a:a").FindNext( _
LookUpCell)
Loop While LookupCell.Address <> fAddr
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
fAddr = LookUpCell.Address
Do
LookUpCell.Offset(, 1) = LookUpCell.Offset(,1)
& _
r.Offset(, -1).Value & ";"
Set LookUpCell = ws1.Range("a:a").FindNext( _
LookUpCell)
Loop While LookupCell.Address <> fAddr
End If
Next
End If
End If
Next
With ws1
For Each r In .Range("b1", .Range("b65536").End(xlUp))
if Right(r,1) = ";" then
r = Left(r,len(r)-1)
end if
Next
Set ws1 = Nothing: Set ws2 = Nothing: Erase txt
End With
End Sub

 

[Chris]

Thanks for you help Tom, it does exactly what i ment.
Only he said that fAddr whasn't defined so i had made a:
Dim fAddr
and i have placed een extra extra: End With, at the end.
maybe this isnt the way you have made it so please tell me if i did somthing wrong.

Thanks again

Chris

 

[Chris]

As i said before the code i just get from Tom is working fine, till
now..
I discovered that in one company not all the employee names can fit to
one cell. Verry logical because there are +/- 6000 of them.
I've searched in som other topics but i couldn't find a code that
begin to fill a cell to the right when the first one is full.
Offcourse he may not break a employee name in two parts. Is there a
simple solution code for this?
Or is it just not possible.
btw i don't get an error, he just stops with looking for other
employee names (i think), so maybe it is not even related to the cell
capicity..... Hope you can give me som advice.

Chris

 

[Tom Ogilvy]

Change MAXLENGTH to the maximum string length (number of characters) you
want in a cell. It will not split a name (but could slightly exceed
MAXLENGTH). It assumes all cells to the right are available to place the
data.

Sub test()
Const MAXLENGTH as Long = 5000
Dim r As Range, txt, ws1 As Worksheet, ws2 As Worksheet
Dim LookUpCell As Range, x
Dim faddr as String, rng as Range, r1 as Range
Set ws1 = Sheets("FireWall Rules"): Set ws2 = Sheets("LDAP")
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
fAddr = LookupCell.Address
do
set rng = LookUpCell.offset(,1)
do while len(rng) > MAXLENGTH
set rng = rng.offset(0,1)
Loop
rng = rng & _
r.Offset(, -1).Value & ";"
Set LookUpCell = ws1.Range("a:a").FindNext( _
LookUpCell)
Loop While LookupCell.Address <> fAddr
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
fAddr = LookUpCell.Address
Do

set rng = LookUpCell.offset(,1)
do while len(rng) > MAXLENGTH
set rng = rng.offset(0,1)
Loop
rng = rng & _
r.Offset(, -1).Value & ";"
Set LookUpCell = ws1.Range("a:a").FindNext( _
LookUpCell)
Loop While LookupCell.Address <> fAddr
End If
Next
End If
End If
Next
End With

With ws1
For Each r In .Range("b1", .Range("b65536").End(xlUp))
set r1 = r
do while len(trim(r1)) <> 0
if Right(r1,1) = ";" then
r = Left(r1,len(r1)-1)
end if
set r1 = r1.offset(0,1)
Loop
Next
Set ws1 = Nothing: Set ws2 = Nothing: Erase txt
End With
End Sub