Create Hyperlink to cell on another worksheet dynamically via VBA

Hi there.  Using Excel 2007 and Windows 7.

I've made an inventory workbook that has some conditional formatting so that when my quanitity gets equal to or lower than 25% of what I want to keep on hand, that cell turns red.  Also, when the quanitity cell changes, my VBA script goes through the first sheet and any row it finds meets the criteria of my conditional formatting =(E2<=(0.25*I2))  it copies it to the SUMMARY page.

What I am wanting is a for the quanitity cell on my SUMMARY page to be a hyperlink to that row on that sheet.  Also, I do not know how to change my existing VBA to go through all sheets and update the summary sheet.

Any suggestions?
CopyPlaceHyperLink.xlsm
John DesselleAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
Hi,

pls try

Sheet1.Hyperlinks.Add Anchor:=Sheet1.Cells(R2, 1), Address:="", SubAddress:= _
        "'" & Sheet2.Name & "'!" & Cells(R, 1).Address, TextToDisplay:=Sheet2.Cells(R, 1).Text

Open in new window

Regards
0
John DesselleAuthor Commented:
That worked like a charm.  Thank you very much.  

Do you know how I could make my code work for all the worksheets and any new sheets that may be added?
0
Rgonzo1971Commented:
Hi,

you could use a for each

For Each sh In ActiveWorkbook.Sheets(Array("Ink and Toner", "HASMAT"))
' your code
next

Open in new window

and then use the sh as an argument for your subprocedures

Sub CopyRow(ByVal R As Integer, mySh as Worksheet)

    If WorksheetFunction.CountA(mySh .Cells) = 0 Then
        R2 = 1
    Else
        R2 = mySh .Range("A" & mySh .Rows.Count).End(xlUp).Row + 1
    End If
    
    CopyRow2 R, R2, mySh
End Sub

Open in new window

0
10 Tips to Protect Your Business from Ransomware

Did you know that ransomware is the most widespread, destructive malware in the world today? It accounts for 39% of all security breaches, with ransomware gangsters projected to make $11.5B in profits from online extortion by 2019.

John DesselleAuthor Commented:
I'm not sure I follow your code.  It seems to me that I would need to remove a lot of my code, the lines like:  
Sheet1.Cells(R2, 1) = Sheet2.Cells(R, 1)

Open in new window

in order for yours to work.

And if so, I'm not exactly positive where I would put your
For Each....

Open in new window

section.

Thanks for the help.
0
Rgonzo1971Commented:
Hi,
I havent adapted everything but here is the basic framework

Dim R2 As Integer

Sub InitCopyRow()
Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets(Array("Ink and Toner", "HASMAT"))

        For I = 2 To sh.UsedRange.Rows.Count
            If sh.Cells(I, 5) <= (0.25 * (sh.Cells(I, 9))) Then
            
            CopyRow I, sh
            
            End If
        Next
    Next
End Sub


Sub CopyRow2(ByVal R As Integer, ByVal R2 As Integer, sht As Worksheet)
Dim HL As String
    Sheet1.Cells(R2, 1) = sht.Cells(R, 1)
    Sheet1.Cells(R2, 2) = sht.Cells(R, 2)
    Sheet1.Cells(R2, 3) = sht.Cells(R, 3)
    Sheet1.Cells(R2, 4) = sht.Cells(R, 4)
    Sheet1.Cells(R2, 5) = sht.Cells(R, 5)
    Sheet1.Hyperlinks.Add Anchor:=Sheet1.Cells(R2, 1), Address:="", SubAddress:= _
        "'" & sht.Name & "'!" & sht.Cells(R, 1).Address, TextToDisplay:=sht.Cells(R, 1).Text
        
    
    
    'Sheet1.Hyperlinks.Add anchor:=Sheet1.Cells(R2, 5), _
    'SubAddress:=Sheet1.Cells(R2, 5), _
    'TextToDisplay:=""
    Sheet1.Cells(R2, 6) = Sheet2.Cells(R, 6)
    Sheet1.Cells(R2, 7) = Sheet2.Cells(R, 7)
    Sheet1.Cells(R2, 8) = Sheet2.Cells(R, 8)
    Sheet1.Cells(R2, 9) = Sheet2.Cells(R, 9)
    Sheet1.Cells(R2, 10) = Sheet2.Name
    
    'ActiveSheet.Hyperlinks.Add Anchor:=Sheet1.Cells(R2, 1), Address:="", SubAddress:="'" & Sheet2.Name & "'!A1", TextToDisplay:=""
    
    

    

End Sub

Sub CopyRow(ByVal R As Integer, sht As Worksheet)

    If WorksheetFunction.CountA(Sheet1.Cells) = 0 Then
        R2 = 1
    Else
        R2 = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row + 1
    End If
    
    CopyRow2 R, R2, sht
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
John DesselleAuthor Commented:
This worked just right.  I ended up changing the "Change" code for each worksheet.  Now I just need to copy one clip of code to every new sheet and I should be good.  Here is what I put on the sheets:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim woArea As Range, isect As Range
Set woArea = ActiveSheet.Range("E:E")

Set isect = Application.Intersect(Target, woArea)

If isect Is Nothing Then

Else

    Sheet1.Range("A2:J6666").ClearContents
    
    InitCopyRow
    
End If
    
    
End Sub

Open in new window

0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.