Hyperlinking & the Transferring of the Link Between Worksheets

[nwentling5]

Hey All,

What I am trying to do is transfer data from a Test worksheet to a Master worksheet. When I transfer the data is there a way to also transfer a hyperlink from the Test worksheet to the "Master" worksheet that would transfer the user back to the "Test" worksheet?

Currently on the Test worksheet I have a button that adds a "Link" next to the part column with the following code:

Public Sub cmdLinks_Click()
 Range("B7").Select
    ActiveCell.FormulaR1C1 = "Link"
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "Test!A7", TextToDisplay:=" *Coded* Link Back to Test Worksheet"
 
End Sub

This works fine when I click "Link" on the Test worksheet, but when it is transfered over to the Master worksheet the link no longer works.



A couple of notes:

• I currently have the Update button on the Master list working to where it transfers all of the data from the worksheets.
• I will have the code looped to where each row has a link corresponding to its origin.
• I am using Excel 2007

In the grand schemes of this workbook there will be numerous worksheets putting all of their data on the Master worksheet and this type of linking will make it easier for the user to navigate to a particular worksheet.

Below is a link to a test workbook so you can have an easier understanding of what I am trying to do:
http://dl.dropbox.com/u/8986524/Test1.xlsm

Could anyone point me to a way of doing this or some type of code that could globally work between worksheets? If I am not clear enough please let me know!

Thank you!

 

[Jerry Sullivan]

Hi nwentling5,

Unless there's some reason you need to have the hyperlink stay in your Test sheets, I'd suggest that you have your Update Button function just create a Hyperlink in your Master Sheet that links back the Sheet and Row as you are "copying" that Row.

If you have to "transfer" the Hyperlink from your Test sheets to your Master, the easiest way to do that is by Copying and Pasting the Cell with the Hyperlink.

 

[nwentling5]

Hi JS411,

Thanks for the reply!

I do not need to keep a link on the Test1 worksheet, so using the Update button to place the hyperlink would be perfect. However, I am not sure on how to go about doing that. The Update button's code I received from a co-worker and I am not sure how to manipulate it to link back to the particular sheet.

The Update Button's code is:

Dim NumCount As Long
Dim iSheet, iTargetRow As Long, oCell As Object, bRowWasNotBlank As Boolean
Dim iTop, iLeft, iBottom, iRight As Integer
'Dim sRange As Range
 
'Grabs all of the data from all of the worksheets and throws it onto the master sheet
Const sRange = ("A7:O150")
'sRange = Range(Range("A2"), Range("O" & Rows.Count).End(xlDown))
Application.ScreenUpdating = False
Sheets("Master2").Select
iTargetRow = 2
bRowWasNotBlank = True
For iSheet = 2 To ThisWorkbook.Sheets.Count: DoEvents
For Each oCell In Sheets(iSheet).Range(sRange).Cells: DoEvents
If oCell.Column = 1 Then
    If bRowWasNotBlank Then iTargetRow = iTargetRow + 1
        bRowWasNotBlank = False
    End If
        If oCell.MergeCells Then
            bRowWasNotBlank = True
                If oCell.MergeArea.Cells(1).Row = oCell.Row Then
                    If oCell.MergeArea.Cells(1).Column = oCell.Column Then
                        Sheets("Master2").Cells(iTargetRow, oCell.Column) = oCell
                        iTop = iTargetRow
                        iLeft = oCell.Column
                        iBottom = iTop + oCell.MergeArea.Rows.Count - 1
                        iRight = iLeft + oCell.MergeArea.Columns.Count - 1
                        Sheets("Master2").Range(Cells("A3", iLeft), Cells(iBottom, iRight)).MergeCells = True
                    End If
                End If
            End If
If Len(oCell) Then bRowWasNotBlank = True
    Sheets("Master2").Cells(iTargetRow, oCell.Column) = oCell
    Next oCell
Next
Sheets("Master2").Activate

Could you possibly give me some direction on where to start? I know it needs to probably be placed within this area:

  If oCell.MergeArea.Cells(1).Column = oCell.Column Then
                        Sheets("Master2").Cells(iTargetRow, oCell.Column) = oCell
                        iTop = iTargetRow
                        iLeft = oCell.Column
                        iBottom = iTop + oCell.MergeArea.Rows.Count - 1
                        iRight = iLeft + oCell.MergeArea.Columns.Count - 1
                        Sheets("Master2").Range(Cells("A3", iLeft), Cells(iBottom, iRight)).MergeCells = True
                    End If

But I am not entirely positive. Any idea?

 

[Jerry Sullivan]

Hi nwentling5,

Below is a function that you could use to add Hyperlinks to the first column
of Source Data from the corresponding cells where they are being copied.

The parameters are:
- rSource (The Source Range that was just copied)
- cDest (The first Cell at the Destination where the data was copied)

Copy this code into a Standard Code Module of your Workbook
Always test new code on a Copy of your Workbook file.

Function AddHyperlinksBackToSource(rSource As Range, cDest As Range)
    Dim rCell As Range, iRow&
    For Each rCell In rSource.Resize(, 1)
        With rCell
            .Hyperlinks.Add _
                Anchor:=cDest.Offset(iRow), _
                Address:="", _
                SubAddress:="'" & .Parent.Name & "'!" & .Address, _
                ScreenTip:="Click Me", _
                TextToDisplay:=.Value
            iRow = iRow + 1
        End With
    Next rCell
End Sub

After reviewing your Test1.xlsm file code, I recommend you replace it with one of the many examples
that are available showing how to consolidate data from each worksheet to a summary sheet.

Ron de Bruin's example at the link shown below is a good one because he has nicely annotated it.

Copy this code into the same Standard Code Module as the Function above.

Sub CopyDataWithoutHeaders()
' reply to http://www.mrexcel.com/forum/showthread.php?t=569390
' adapted from Excel MVP Ron de Bruin's code examples at:
' http://msdn.microsoft.com/en-us/library/cc793964.aspx
 
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
' Identify the summary worksheet.
    Set DestSh = ActiveWorkbook.Worksheets("Master2")
    ' Fill in the first row of data on each source sheet
    StartRow = 7
' Loop through all worksheets and copy the data to the summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
     ' Find the last row with data on the summary & source worksheets.
            Last = LastRow(DestSh)
            shLast = LastRow(sh)
        ' If source worksheet is not empty and if the last
        ' row >= StartRow, copy the range.
            If shLast > 0 And shLast >= StartRow Then
                'Set the range that you want to copy
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
            ' This statement copies values & formats from each worksheet
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
                AddHyperlinksBackToSource CopyRng, _
                    DestSh.Cells(Last + 1, "A")
            End If
        End If
    Next
ExitTheSub:
    Application.Goto DestSh.Cells(1)
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 
Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function
 
Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

To call this Sub from your "Update" button, replace your existing code with:

Private Sub btnUpdate_Click()
    CopyDataWithoutHeaders
End Sub

Just let me know if you have any difficulties getting this to work.
It could be a pretty clean solution for you.

It's also useful general purpose code that others could adapt for similar applications.

 

[Jerry Sullivan]

One more note to show the end result for context.

The data from all worksheets in the book will be consolidated on the Summary Sheet.
Each cell in the first Column will have a Hyperlink that ties back to the address where that row was copied from in the workbook.

Excel Workbook
	A	B	C	D	E
1	Master Parts List
2	Parts Number:	Info 1	Info 2	Info 3	Info 4
3	Part 1	31	36	89	93
4	Part 2	21	24	66	83
5	Part 3	22	69	73	16
6	Part 4	60	13	87	35
7	Part 5	96	52	15	31
Master2

nwentling5, note that I deleted Column B that you had previously planned to display the Hyperlinks.
It's probably cleaner to just add the links to Column A.

 

[nwentling5]

JS411,

Thank you for a very thorough reply. It is greatly appreciated! Both of the codes that you have given me work very well! And yes I agree with deleteling the 2nd column giving the worksheet a cleaner look.

I do have a couple questions though.

1)How do I go about manipulating the consolidating code to where it copies over the orginal data instead of adding the data to the bottom of the list each time the update button is pushed?

2) With the hyperlink code, I was messing with it and I accidently left a cell open in column A and the program stopped with the following error: "Run-Time error '5': Invalid procedure call or arguement" and it highlighted the following code:

 .Hyperlinks.Add _
                Anchor:=cDest.Offset(iRow), _
                Address:="", _
                SubAddress:="'" & .Parent.Name & "'!" & .Address, _
                ScreenTip:="Click Me", _
                TextToDisplay:=.Value

My question is how do I go about adding a message box that pops up when the user accidently leaves a blank cell, instead of the program stopping and having its error code pop up?

I will start messing with the code myself and doing some research while I wait for your reply. I believe the error message has something to do with an "On Error" but I am not sure.

Once again, thanks for all of the assistance!

 

[Jerry Sullivan]

1)How do I go about manipulating the consolidating code to where it copies over the orginal data instead of adding the data to the bottom of the list each time the update button is pushed?

To clear previous data without the need for your existing "Clear" button, add this to the Sub CopyDataWithoutHeaders() procedure...

' Identify the summary worksheet
Set DestSh = ActiveWorkbook.Worksheets("Master2")
 
'Clear previous Summary Data.
DestSh.Rows("3:" & Rows.Count).Clear

2) With the hyperlink code, I was messing with it and I accidently left a cell open in column A and the program stopped with the following error: "Run-Time error '5': Invalid procedure call or arguement" and it highlighted the following code:
<SNIP>
My question is how do I go about adding a message box that pops up when the user accidently leaves a blank cell, instead of the program stopping and having its error code pop up?

Glad you caught that- I hadn't considered it. Since we understand that is a potential error, I'd suggest we handle that by inserting a link and using some other temporary text....

Sub AddHyperlinksBackToSource(rSource As Range, cDest As Range)
    Dim rCell As Range, iRow&, sText$
    For Each rCell In rSource.Resize(, 1)
        With rCell
            sText = .Value
<B>           If sText = "" Then sText = "<BLANK>"</B>  'could add msgbox too, if needed.
            .Hyperlinks.Add _
                Anchor:=cDest.Offset(iRow), _
                Address:="", _
                SubAddress:="'" & .Parent.Name & "'!" & .Address, _
                ScreenTip:="Click Me", _
                TextToDisplay:=sText
            iRow = iRow + 1
        End With
    Next rCell
End Sub

Additionally, it would be a good idea to add a general-purpose error handler so the users don't encounter an error that brings them to the Debug environment.

To do that, revise the Sub CopyDataWithoutHeaders() procedure near the top...

Dim StartRow As Long
On Error GoTo ErrorHandler

...and at the bottom.

    Next
Application.Goto DestSh.Cells(1)
ExitTheSub:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
Exit Sub
ErrorHandler:
    MsgBox Err.Number & ": " & Err.Description, vbExclamation, "Error"
    GoTo ExitTheSub
End Sub

 

[nwentling5]

JS411,

The code works great!

I have one more question. How do I get the update code to skip over the first 4 worksheets of my workbook? When I try to implement into my actual project, the first 4 workbooks are Stock_Ref (Made hidden), Master List, Assembly Index, Part Index, and then work orders on each worksheet following.

I just want the work orders to be picked up on the master list. How do I go about doing this?

Thanks again for all of the assistance.

 

[Jerry Sullivan]

I have one more question. How do I get the update code to skip over the first 4 worksheets of my workbook?

Glad to hear that worked for you.

To skip the first 4 sheets you could modify this part...

' Loop through all worksheets and copy the data to the
' summary worksheet.
Dim lWSN As Long
If Worksheets.Count < 5 Then Exit Sub
For lWSN = 5 To Worksheets.Count
    Set sh = Worksheets(lWSN)
    If sh.Name <> DestSh.Name Then

 

[nwentling5]

JS411,
That works great! Thanks for all of the assistance!