Hyperlink Target Extraction to a new Cell

[ken2002]

I've a File with Customer Contact Info, which has a Name and an Mail to Address attached to it. I want to Extract this Email Address and Copy it to a new Adjacent Cell. Example Bill Gates is the Contact Name and As you Click the Hyperlink, the email Program opens with the Address bgates@microsoft.com. I can certainly do one at a time but I've a Contact DB with 6K Addresses. Any help would be apprecited. Tried MS Site but no luck. Please Help!!!!!!!!!

 

[Colo]

Welcome KEN,
Let us know the layout of your data worksheet as follows.

Book1.xls
	A	B	C	D
1	Name	Email	newAdjacentCell
2	BillGates1	bgates1@microsoft.com
3	SteveJobs1	Steve1@Apple.com
4	BillGates2	bgates2@microsoft.com
5	SteveJobs2	Steve2@Apple.com
6	BillGates3	bgates3@microsoft.com
7	SteveJobs3	Steve3@Apple.com
8	BillGates4	bgates4@microsoft.com
9	SteveJobs4	Steve4@Apple.com
10	BillGates5	bgates5@microsoft.com
11	SteveJobs5	Steve5@Apple.com
12	BillGates6	bgates6@microsoft.com
13	SteveJobs6	Steve6@Apple.com
14	BillGates7	bgates7@microsoft.com
15	SteveJobs7	Steve7@Apple.com
16	BillGates8	bgates8@microsoft.com
17	SteveJobs8	Steve8@Apple.com
18	BillGates9	bgates9@microsoft.com
19	SteveJobs9	Steve9@Apple.com
20	BillGates10	bgates10@microsoft.com
Sheet1

 

[ken2002]

I don't know how to post the spreadsheet with the HTML Converter. But here is the Example
Col A Col B Col C
Company Contact Extracted Email Address

Microsoft Bill Gates

need to extract the attached Email Address created using the hyperlink Mail to Function
Bgates@microsoft.com is entered using the hyperlink function.

Hope you understand this.

 

[Colo]

Hi please try this one.<PRE><FONT color=red>Sub</FONT>GetEmailAddress()<FONT color=#339966>'Put this code on STD module</FONT><FONT color=red>Dim</FONT>rngData<FONT color=red>As</FONT> Range, rng<FONT color=red>As</FONT> Range<FONT color=red>With</FONT>Sheets("Sheet1")<FONT color=#339966>'Change here to name of data worksheet.</FONT><FONT color=red>Set</FONT>rngData = .Range(.[B2], [B65536].End(xlUp))<FONT color=red>End With</FONT><FONT color=red>On Error</FONT><FONT color=red>Resume</FONT>Next<FONT color=red>For</FONT>Each rng In rngData

rng.Offset(, 1).Value = Mid(rng.Hyperlinks(1).Address, 8)

Next<FONT color=red>End Sub</FONT></PRE>
This message was edited by Colo on 2002-10-09 01:26

 

[Colo]

KEN, I sent an email with Workbook.

 

[ken2002]

Thank you very much for your help "Colo". The Code worked like a Charm and I'm already using it to create my new DB. This Forum is just Great. Thanks again for all you help.