Macro to remove web addresses

[griffinwebnet]

I have written a macro to extract the addresses from hyperlinks, and paste them in the cell to the right, it them removes the 'mailto:' if its an email address, and its supposed to delete the contents of the cell if it starts with 'http:' because were not interested in web sites. however it extracts and removes mailto: but in the last step it removes random email addresses from the list as well. addresses that dont have http: and it sometimes fails to remove actual web addresses.

Here is my code:

Sub ExtractHL()
'Extracts the destination of all hyperlinks
Dim HL As Hyperlink
    For Each HL In ActiveSheet.Hyperlinks
        HL.Range.Offset(0, 1).Value = HL.Address
    Next
'Removes Mailto from the destination addresses if an email
   Cells.Replace What:="mailto:", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'Deletes all non email addresses
Dim cell As Range
    For Each cell In ActiveSheet.UsedRange
    If cell.Text >= "http:" Then cell.ClearContents
Next
'Removes All HyperLinks
Cells.Hyperlinks.Delete
End Sub

-JL

 

[pboltonchina]

Try replacing

If cell.Text >= "http:" Then cell.ClearContents

with

If cell.Text >= "http:*" Then cell.ClearContents

 

[griffinwebnet]

Try replacing

If cell.Text >= "http:*" Then cell.ClearContents

that didnt work. It is still deleting data that it shouldnt.

HJere is a sample book. since i cant post attachments, ill have tou host it on my server. http://webnetforum.com/projektor/proj/Excel/Sample_book.xlsm

When you save it it will want to save as a .zip for some reason. It's not a '.zip'. just change to all file types and add '.xlsm' to the end.

first run HLExtractor, then run httpremover and you'll see what i am talking about.

-JL

 

[pboltonchina]

I've had a look and can't make any sense of what is happening. I've tried several different methods to obtain the desired result without success.
Maybe someone else can have a look for you.

 

[Rick Rothstein]

What happens if you change this line...

If cell.Text >= "http:" Then cell.ClearContents

to this...

If cell.Text Like "http:*" Then cell.ClearContents

 

[pboltonchina]

I tried that without success

 

[Rick Rothstein]

Okay, think this may do what you want (really, I do ). Change your "'Deletes all non email addresses" section to this...

'Deletes all non email addresses
   Cells.Replace What:="http:*", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

 

[griffinwebnet]

Okay, think this may do what you want (really, I do ). Change your "'Deletes all non email addresses" section to this...

'Deletes all non email addresses
   Cells.Replace What:="http:*", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

Thank You Thank you! That worked beautifully. i cant believe that i didnt think of it since i use the same function to remove 'mailto:'. Brilliant!

Lol. Thank You All For your help!

-JL Griffin