macro to get cell value from hyperlink target 1

[dippncope]

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.

 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

 

[SkipVought]

Hi,

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]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[dippncope]

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

 

[SkipVought]

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]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[dippncope]

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.

 

[SkipVought]

STEP (F8) thru your code.

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

 

[dippncope]

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.

 

[SkipVought]

Try this then

    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]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[SkipVought]

I believe that this is preferable...

    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]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[dippncope]

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

 

[SkipVought]

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]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[SkipVought]

Try this...

    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]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[dippncope]

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

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

 

[SkipVought]

Check out my previous post using the hyperlink object directly.

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