Need help copy the cell that contain hyperlink and paste it in other col. Thanks for helping!

[pedie]

Hi,
I have data from B1:B4642 only, if any of the cell contain hyperlink then
copy cell (Using all source theme) and paste it col C finding the next empty cell.

Thank you for helping!
Pedie

 

[pedie]

This code does not work...I am trying in different ways...
my try code below...I just dono who to set it up

Sub FNRMacro()
Dim hl As Hyperlink
For i = 1 To 600
  Set hl = Nothing
     On Error Resume Next
       Set hl = Sheet1.Range("B" & i).Hyperlinks(1)
        If Err Or hl Is Nothing Then
          Exit Sub
           Else
            hl.Copy
            Range("C1").Select
           Do Until ActiveCell.Value = ""
         ActiveCell.Offset(3, 0).Select
       Loop
            Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=True
                               
            
        End If
    
    Next i
    
End Sub

 

[pedie]

bump...!
Sorry

 

[pedie]

I found something very near to what I want but not exactly. Maybe someone can edit or design something similiar.....
The current code list all the hyperlink if there is hyperlink in cell.
However what I am looking for here copy the whole cell with cell.value + hyperlink then paste it in col C. Hoping someone will come by!

Where is VoG, Brian, Norie, Lenze, Mike.....

[COLOR=blue]Option Explicit[/COLOR] 
 
[COLOR=blue]Private[/COLOR] [COLOR=blue]Function[/COLOR] GetHyperAddy(Cell [COLOR=blue]As[/COLOR] Range) [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR] 
     [COLOR=darkgreen]'Function purpose:  To return a hyperlink address if one exists[/COLOR]
     [COLOR=darkgreen]'Assigns a value of "None" to the string if no hyperlink is present[/COLOR]
 
    [COLOR=blue]On Error Resume Next[/COLOR] 
    GetHyperAddy = Cell.Hyperlinks.Item(1).Address 
    [COLOR=blue]If[/COLOR] Err.Number <> 0 [COLOR=blue]Then[/COLOR] GetHyperAddy = "None" 
    [COLOR=blue]On Error Goto[/COLOR] 0 
 
[COLOR=blue]End Function[/COLOR] 
 
[COLOR=blue]Sub[/COLOR] DistillHyperlinks() 
     [COLOR=darkgreen]'Macro purpose:  To create a list of all Hyperlinks and their[/COLOR]
     [COLOR=darkgreen]'addresses contained within a selection of cells[/COLOR]
 
    [COLOR=blue]Dim[/COLOR] HyperAddy [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR], cl [COLOR=blue]As[/COLOR] Range, wsTarget [COLOR=blue]As[/COLOR] Worksheet, clSource [COLOR=blue]As[/COLOR] Range 
 
     [COLOR=darkgreen]'Turn off screen flashing[/COLOR]
    Application.ScreenUpdating = [COLOR=blue]False[/COLOR] 
 
     [COLOR=darkgreen]'Following required as adding worksheet changes selection[/COLOR]
    [COLOR=blue]Set[/COLOR] clSource = Selection 
 
     [COLOR=darkgreen]'Check to see if a "Hyperlink List" worksheet exists, and[/COLOR]
     [COLOR=darkgreen]'create it if it doesn't[/COLOR]
    [COLOR=blue]On Error Resume Next[/COLOR] 
    [COLOR=blue]Set[/COLOR] wsTarget = Sheets("Hyperlink List") 
    [COLOR=blue]If[/COLOR] Err.Number <> 0 [COLOR=blue]Then[/COLOR] 
        [COLOR=blue]Set[/COLOR] wsTarget = Worksheets.Add 
        [COLOR=blue]With[/COLOR] wsTarget 
            .Name = "Hyperlink List" 
            [COLOR=blue]With[/COLOR] .Range("A1") 
                .Value = "Location" 
                .ColumnWidth = 20 
                .Font.Bold = [COLOR=blue]True[/COLOR] 
            [COLOR=blue]End With[/COLOR] 
            [COLOR=blue]With[/COLOR] .Range("B1") 
                .Value = "Displayed Text" 
                .ColumnWidth = 25 
                .Font.Bold = [COLOR=blue]True[/COLOR] 
            [COLOR=blue]End With[/COLOR] 
            [COLOR=blue]With[/COLOR] .Range("C1") 
                .Value = "Hyperlink Target" 
                .ColumnWidth = 40 
                .Font.Bold = [COLOR=blue]True[/COLOR] 
            [COLOR=blue]End With[/COLOR] 
        [COLOR=blue]End With[/COLOR] 
        [COLOR=blue]Set[/COLOR] wsTarget = Sheets("Hyperlink List") 
    [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
    [COLOR=blue]On Error Goto[/COLOR] 0 
 
     [COLOR=darkgreen]'Loop through each cell in the user's selection and...[/COLOR]
    [COLOR=blue]For Each[/COLOR] cl [COLOR=blue]In[/COLOR] clSource 
         [COLOR=darkgreen]'Get the hyperlink address[/COLOR]
        HyperAddy = GetHyperAddy(cl) 
 
        [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] HyperAddy = "None" [COLOR=blue]Then[/COLOR] 
             [COLOR=darkgreen]'If Hyperlink exists, add it to the list on the target sheet[/COLOR]
            [COLOR=blue]With[/COLOR] wsTarget.Range("A65536").End(xlUp).Offset(1, 0) 
                 [COLOR=darkgreen]'Create hyperlink to cell containing hyperlink[/COLOR]
                .Parent.Hyperlinks.Add Anchor:=.Offset(0, 0), _ 
                Address:="", SubAddress:=(cl.Parent.Name) & "!" & (cl.Address) 
                 [COLOR=darkgreen]'List text shown on hyperlink[/COLOR]
                .Offset(0, 1).Value = cl.Text 
                 [COLOR=darkgreen]'Create hyperlink to destination[/COLOR]
                .Hyperlinks.Add Anchor:=.Offset(0, 2), Address:=HyperAddy 
            [COLOR=blue]End With[/COLOR] 
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
    [COLOR=blue]Next[/COLOR] cl 
    wsTarget.Select 
[COLOR=blue]End Sub[/COLOR]

 

[meldoc]

Pedie be patient,

I know nothing about Hyperlinks, I have had to learn about them so I could answer your question.

Try this, it is in response to your first post, there is probably a better way to do this, see how you go on.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> FNRMacro()<br>  <SPAN style="color:#00007F">With</SPAN> Worksheets(1)<br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> hl <SPAN style="color:#00007F">In</SPAN> .Range("B1:B4642").Hyperlinks<br>      .Hyperlinks.Add .Cells(Rows.Count, "C").End(xlUp).Offset(1), hl.Address<br>    <SPAN style="color:#00007F">Next</SPAN> hl<br>  <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[pedie]

I think this good enough for now...thanks everyone!

 

[pedie]

Brian, thank you so much!
I think we cross posted it. I show your post after I posted this is good enough!!! Thanks alot!~

I was patient but you know sometimes when we dont bump it it takes like 3 days to get the answer

Thanks again!!!

 

[pedie]

Pedie be patient,
I know nothing about Hyperlinks, I have had to learn about them so I could answer your question.

Brian....!!! Thanks a million again!!!

 

[meldoc]

You're welcome Pedie