Hyperlinks to return active cell value.

S

sdhak002

New Member
Joined
Mar 13, 2018
Messages
1
Hi everyone,

I am trying to get the following macro to work. The first tab has a column (F17:F2000) with hyperlinks that return the value on the cell thats clicked. When a user click the cell F17. It will return the value on that cell (User ID) to another cell.

The worksheet has a large macro that runs perfectly and following is supposed to be a small piece and I dont know how to make it work. I am providing both the larger macro and the one with hyperlink below. Hope you all can help!



Code: 
[COLOR=#ff0000]Dim GSourceCell As String

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Debug.Print Target.Address
   'Update cell i15 in Destination sheet based on the origin of hyperlink
   If Sh.Name = "Workflow Management Tool" Then
      If GSourceCell = "G21" Then
         Sheets("Member Details").Range("I12").Value = "A"
         'Sheets("Workflow Management Tool").Range("g21").Value
      ElseIf GSourceCell = "G22" Then
         Sheets("Member Details").Range("I12").Value = Sheets("Workflow Management Tool").Range("g22").Value
      ElseIf GSourceCell = "G23" Then
         Sheets("Member Details").Range("I12").Value = Sheets("Workflow Management Tool").Range("g23").Value
      Else
         Sheets("Member Details").Range("I12").Value = "Error!"
      End If
   End If

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

   If Sh.Name = "Workflow Management Tool" Then
      'Capture last active cell on Hyperlinks worksheet and store in global variable
      GSourceCell = Target.Address(False, False)
   End If

End Sub

[/COLOR]
[COLOR=#008000]Sub filter_stuff()
'
Dim rCrit1 As Range, rCrit2 As Range, rRng1 As Range, rRng2 As Range

  'copy  paste store no for walgreens
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
On Error GoTo ErrMsg

    Sheets("Workflow Management Tool").Select
    Range("l9").Select
    Selection.Copy
    Sheets("Task Details").Select
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Raw Data").Select
    Range("a3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
     
'test Sheets("Task Details").Select
' range calls made in the beginning
' The ISEMPTY function returns FALSE if the value is a cell or variable that contains a value (ie: is not empty).
  
Sheets("Task Details").Select
    Selection.AutoFilter
     Range("A5:R200000").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort.SortFields.Add Key _
        :=Range("L5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort.SortFields.Add Key _
        :=Range("C5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort.SortFields.Add Key _
        :=Range("F5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort.SortFields.Add Key _
        :=Range("E5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Task Details").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        'ActiveSheet.Range("A5:R200000").AutoFilter Field:=12, Criteria1:=Array("1", "2", "0")
    If IsEmpty(Range("A3").Value) = False Then
        ActiveSheet.Range("A5:R200000").AutoFilter Field:=4, Criteria1:=Range("A3").Value
    End If
    If IsEmpty(Range("C3").Value) = False Then
        ActiveSheet.Range("A5:R200000").AutoFilter Field:=1, Criteria1:=Range("C3").Value
    End If
Sheets("Task Details").Range("A6:R10000").Select

Sheets("Raw Data").Select

    If IsEmpty(Range("A3").Value) = False Then
      ActiveSheet.Range("A5:AB200000").AutoFilter Field:=20, Criteria1:=Range("A3").Value
      End If
    If IsEmpty(Range("C3").Value) = False Then
      ActiveSheet.Range("A5:AB200000").AutoFilter Field:=3, Criteria1:=Range("C3").Value
    End If

    Sheets("Workflow Management Tool").Select
 'Add the grey tables - start adding member details on the bottom
  
    Range("f16").Select
    ActiveCell.FormulaR1C1 = "Member ID"
    Range("g16").Select
    ActiveCell.FormulaR1C1 = "Program Eligible"
    Range("h16").Select
    ActiveCell.FormulaR1C1 = "First Name"
    Range("i16").Select
    ActiveCell.FormulaR1C1 = "Last Name"
    Range("j16").Select
    ActiveCell.FormulaR1C1 = "Phone Number"
    Range("k16").Select
    ActiveCell.FormulaR1C1 = "Call No.s"
    Range("L16").Select
    ActiveCell.FormulaR1C1 = "Call Outcome"
    Range("M16").Select
    ActiveCell.FormulaR1C1 = "Last Call Date"
    Range("N16").Select
    ActiveCell.FormulaR1C1 = "Action Needed"
    
 '"Member ID"
 Sheets("Task Details").Select
    Range("A6:A10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("f17").Select
    ActiveSheet.Paste
'Program Eligible"
Sheets("Task Details").Select
    Range("C6:C10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("g17").Select
    ActiveSheet.Paste
'First Name"
Sheets("Task Details").Select
    Range("E6:e10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("h17").Select
    ActiveSheet.Paste
'Last Name
Sheets("Task Details").Select
    Range("f6:f10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("i17").Select
    ActiveSheet.Paste
'Phone Number
Sheets("Task Details").Select
    Range("j6:j10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("j17").Select
    ActiveSheet.Paste
'Call No.s
Sheets("Task Details").Select
    Range("l6:l10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("k17").Select
    ActiveSheet.Paste
'Call Outcome
Sheets("Task Details").Select
    Range("p6:p10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("L17").Select
    ActiveSheet.Paste
'Last Call Date
Sheets("Task Details").Select
    Range("o6:o10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("m17").Select
    ActiveSheet.Paste
'Action Needed
Sheets("Task Details").Select
    Range("r6:r10000").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("Workflow Management Tool").Select
    Range("n17").Select
    ActiveSheet.Paste
 
    'Decoration Fluff stuff
    '
    Range("f16:n16").Select
    
    With Selection.Font
        .Name = "Cambria"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMajor
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -4.99893185216834E-02
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -4.99893185216834E-02
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -4.99893185216834E-02
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -4.99893185216834E-02
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -4.99893185216834E-02
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.498031556138798
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0.5)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.250984221930601
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.498031556138798
    End With
    Range("f17:n17").Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Selection.Font.Underline = xlUnderlineStyleNone
    With Selection
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    Range("f17:f200000").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "'Member Details'!k1"
            
Exit Sub

ErrMsg:
MsgBox ("Please try again with valid selections. If error persists, please contact Shikha Dhakal for trobleshooting!"), , "Error Handler"
Sheets("Workflow Management Tool").Select
End Sub
[/COLOR]
 
Last edited by a moderator:

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
331
RoryA
RoryA
J
  • Question
Issue with Macros and renaming files
Replies
6
Views
489
kevin9999
K
willow1985
  • Solved
Find first blank cell in column A in a Table - Runtime error 91
Replies
4
Views
104
willow1985
willow1985
J
  • Question
VBA Code to Add Rows is slowing down
Replies
5
Views
504
JayB0730
J
D
  • Question
VBA optimization advice
Replies
3
Views
95
bobsan42
bobsan42

Forum statistics

Threads
1,214,918
Messages
6,122,246
Members
449,075
Latest member
staticfluids

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top