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

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question Question
Help Cleaning Up Code
Replies
2
Views
576
RoryA
RoryA
J
  • Question Question
VBA removing heading in spreadsheet
Replies
3
Views
239
rlv01
R
J
  • Question Question
Issue with Macros and renaming files
Replies
6
Views
996
kevin9999
K
Lacan
  • Solved
Make VBA codes according to one specific sheet and not all entire workbook?
2
Replies
11
Views
324
Lacan
Lacan
willow1985
  • Solved
Find first blank cell in column A in a Table - Runtime error 91
Replies
4
Views
382
willow1985
willow1985

Forum statistics

Threads
1,223,228
Messages
6,170,875
Members
452,363
Latest member
merico17

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