Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Match and Copy
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Match and Copy
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 -- Regards, Tom Ogilvy "Chris" wrote in message om... 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Match and Copy
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Match and Copy
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" wrote in message roups.com... 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Match and Copy
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. 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) 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Match and Copy
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 -- Regards, Tom Ogilvy "Chris" wrote in message om... 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" wrote in message roups.com... 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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Match and Copy
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 :) "Tom Ogilvy" wrote in message ... 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 -- Regards, Tom Ogilvy "Chris" wrote in message om... 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" wrote in message roups.com... 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Match with copy | Excel Discussion (Misc queries) | |||
Match and copy | Excel Worksheet Functions | |||
Match and Copy | Excel Worksheet Functions | |||
Copy to next empty row, if not a match | Excel Discussion (Misc queries) | |||
Maybe this isn't possible to match name and copy? | Excel Programming |