Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

macro to get cell value from hyperlink target 1

Status
Not open for further replies.

dippncope

Technical User
Sep 22, 2008
88
US
Hello. I have a spreadsheet that gets added to weekly. the workbook has a table of contents page with hyperlinks to worksheets in book
TOC sheet list worksheet names as hyperlinks starting in cell C7. I have a macro that will follow hyperlink and copy cell B4 from target and paste it on TOC sheet G7. I need help getting the macro to continue down column C and copy target and stop when it gets to first blank cell in column C below is what I have so far It was created by recording the macro.




Code:
 Sub Macro5()
'
    Range("C7").Select
    Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
    Range("B4").Select
    Selection.Copy
    Sheets("TOC").Select
    Range("G7").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub
 



Hi,
Code:
Sub Macro5()
'
    Dim r As Range

    With Sheets("TOC")
        For Each r In .Range(.Cells(7, "C"), .Cells(7, "C").End(xlDown))
            r.Select
            ActiveSheet.Range("B4").Copy
            .Cells(r.Row, "G").PasteSpecial Paste:=xlPasteValues
        Next
    End With
End Sub

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Skip,
Thanks for response. The code you posted runs with out displaying an error but there is a small issue. It only pastes the value for from the first target into Column G.
This is what the results look like
Column C Column G
test1 1
test2 1
test3 1
Test4 1
And it should be
Column C Column G
test1 1
test2 2
test3 3
Test4 4
 

Code:
Sub Macro5()
'
    Dim r As Range

    With Sheets("TOC")
        For Each r In .Range(.Cells(7, "C"), .Cells(7, "C").End(xlDown))
            r.Select
            ActiveSheet.Range("B4").Copy[b]
            .Activate[/b]
            .Cells(r.Row, "G").PasteSpecial Paste:=xlPasteValues
        Next
    End With
End Sub

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Thanks again. Sorry for late reply. This works for target in C7. but it does not get cell value from target in C8 C9 and so on. If I am not explaining properly please let me know.
 



STEP (F8) thru your code.

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Skip. OK here is what is happening. macro is not following the hyperlink but is copying cell value from TOC sheet B4. happened to be same value as target in hyperlink.
 


Try this then
Code:
    With Sheets("TOC")
        For Each r In .Range(.Cells(7, "C"), .Cells(7, "C").End(xlDown))[b]
            Sheets(Split(r.Hyperlinks(1).Name, "!")(0)).Activate[/b]
            ActiveSheet.Range("B4").Copy
            .Cells(r.Row, "G").PasteSpecial Paste:=xlPasteValues
        Next
    End With


Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 



I believe that this is preferable...
Code:
    Dim r As Range

    With Sheets("TOC")
        For Each r In .Range(.Cells(7, "C"), .Cells(7, "C").End(xlDown))[b]
            Sheets(Split(r.Hyperlinks(1).SubAddress, "!")(0)).Range("B4").Copy[/b]
            .Cells(r.Row, "G").PasteSpecial Paste:=xlPasteValues
        Next
    End With

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Skip. post 2 above the try this one works. it goes to each hyperlink and gets data and pastes it. I just have to end the loop when it hits a blank cell in column C.

the second one, 1 post above errors with Runtime error 9: subscript out of range on line Sheets(Split(r.Hyperlinks(1).SubAddress, "!")(0)).Range("B4").Copy

I do thank you for all you help you have been fantastic
 


Runs for me.

Just posting the error mesage, is insufficient!

You need to also post the VALUE of
[tt]
Sheets(Split(r.Hyperlinks(1).SubAddress, "!")(0)).Name
[/tt]
when you get the error. Use your Watch Window!

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 



Try this...
Code:
    Dim h As Hyperlink

    With Sheets("TOC")
        For Each h In .Hyperlinks
            Sheets(Split(h.SubAddress, "!")(0)).Range("B4").Copy
            .Cells(h.Range.Row, "G").PasteSpecial Paste:=xlPasteValues
        Next
    End With


Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Skip Watch window did not display anything However I changed
Sheets(Split(r.Hyperlinks(1).SubAddress, "!")(0)).Range("B4").Copy

to Sheets(Split(r.Hyperlinks(1).Name, "!")(0)).Range("B4").Copy
and it works perfectly

Code:
Sub Macro5()
Dim r As Range

    With Sheets("TOC")
        For Each r In .Range(.Cells(7, "C"), .Cells(7, "C").End(xlDown))
            Sheets(Split(r.Hyperlinks(1).Name, "!")(0)).Range("B4").Copy
            .Cells(r.Row, "G").PasteSpecial Paste:=xlPasteValues
        Next
    End With
End Sub
 



Check out my previous post using the hyperlink object directly.

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top