VBA code to hyperlink to current selected cell

[willow1985]

I have a code that creates a file and names it after Cell B1:

Sub Create()
'
' Create Macro
'

Msg = " A new IAR will be created along with a folder in the following directory: S:\Lean Folder\IAR Submissions\" & vbCrLf & "" & vbCrLf & " Do you wish to proceed?"

    Ans = MsgBox(Msg, vbYesNo)

    Select Case Ans

        Case vbYes
Range("B1").Select
Selection.Copy
    Range("U1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
  For Each lo In ActiveSheet.ListObjects
 
    lo.AutoFilter.ShowAllData
      Next lo
    Range("B1").Select
    Selection.Copy
    Range("A3").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    MkDir "S:\Lean Folder\IAR Submissions\" & Range("U1").Value 'Would like a hyperlink to the current selected cell at this point
    Range(Cells(Selection.Row, 9), Cells(Selection.Row, 9)).Select
    ActiveCell.FormulaR1C1 = "New"
    With ActiveSheet
   .PageSetup.PrintArea = _
       .Range("Print_Area").Offset(2).Resize(.Range("Print_Area").Rows.Count - 1, _
       .Range("Print_Area").Columns.Count).Address
End With

Case vbNo
        GoTo Quit:
    End Select

Quit:

Is there a way to also create a hyperlink to this newly created folder to the current active cell?

 

[davesexcel]

It looks like you are using the macro recorder for some of this code. You can also use the macro recorder to create the hyperlink. Then the code can be edited after.
with your macro recorder select your cell, hit Ctrl & K or right click the cell to create the hyperlink. Create your hyperlink, stop recording and look at the code.

 

[willow1985]

I don't understand. I need it to link to the newly created folder. If you right click and select link you have to still select the directory but that directory will change every time (different folder name each time).
Using the macro recorder won't work for this.

 

[DanteAmor]

I made some adjustments to your code, deleted lines that are not necessary.
Try this:

Sub Create()
'
' Create Macro
'
  Dim msg, ans, lo, sFolder
  msg = " A new IAR will be created along with a folder in the following directory: S:\Lean Folder\IAR Submissions\" & vbCrLf & "" & vbCrLf & " Do you wish to proceed?"
  If msg = vbNo Then Exit Sub
  Range("U1").Value = Range("B1").Value
 
  For Each lo In ActiveSheet.ListObjects
    lo.AutoFilter.ShowAllData
  Next lo
 
  Range("A3").End(xlDown).Offset(1, 0).Select
  Selection.Value = Range("B1").Value
  With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
  End With
    
  sFolder = "S:\Lean Folder\IAR Submissions\" & Range("U1").Value
  If Dir(sFolder, vbDirectory) = "" Then
    MkDir sFolder
  End If
  ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=sFolder
    
  Range(Cells(Selection.Row, 9), Cells(Selection.Row, 9)).Select
  ActiveCell.FormulaR1C1 = "New"
  With ActiveSheet
    .PageSetup.PrintArea = _
      .Range("Print_Area").Offset(2).Resize(.Range("Print_Area").Rows.Count - 1, _
      .Range("Print_Area").Columns.Count).Address
  End With
End Sub

 

[willow1985]

I cannot have cells B1 and U1 linked in anyway because as soon as B1 text is pasted in the blank row its value will change.

Cell B1 has a formula that looks in column A and determines the next number sequence. That is why I am using U1. It copies B1 to U1 and then creates the new row.

If I am reading your modification right, I will end up with a folder with an incorrect file name

 

[DanteAmor]

Forget my code, let's do it on your code.
Try and tell me

Sub Create()
'
' Create Macro
'

msg = " A new IAR will be created along with a folder in the following directory: S:\Lean Folder\IAR Submissions\" & vbCrLf & "" & vbCrLf & " Do you wish to proceed?"

    ans = MsgBox(msg, vbYesNo)

    Select Case ans

        Case vbYes
Range("B1").Select
Selection.Copy
    Range("U1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
  For Each lo In ActiveSheet.ListObjects
 
    lo.AutoFilter.ShowAllData
      Next lo
    Range("B1").Select
    Selection.Copy
    Range("A3").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
  Dim sFolder
  sFolder = "S:\Lean Folder\IAR Submissions\" & Range("U1").Value
  If Dir(sFolder, vbDirectory) = "" Then
    MkDir sFolder
  End If
  ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=sFolder

    'MkDir "S:\Lean Folder\IAR Submissions\" & Range("U1").Value 'Would like a hyperlink to the current selected cell at this point
    
    Range(Cells(Selection.Row, 9), Cells(Selection.Row, 9)).Select
    ActiveCell.FormulaR1C1 = "New"
    With ActiveSheet
   .PageSetup.PrintArea = _
       .Range("Print_Area").Offset(2).Resize(.Range("Print_Area").Rows.Count - 1, _
       .Range("Print_Area").Columns.Count).Address
End With

Case vbNo
        GoTo Quit:
    End Select

Quit:
End Sub

 

[willow1985]

I might be reading the code wrong however....

This portion works exactly how I need it to though ?

  sFolder = "S:\Lean Folder\IAR Submissions\" & Range("U1").Value
  If Dir(sFolder, vbDirectory) = "" Then
    MkDir sFolder
  End If
  ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=sFolder

 

[DanteAmor]

Glad to know that it already works for you. Thanks for the feedback.

 

[willow1985]

Works Great!

Thank you very much! ??

 

[DanteAmor]

Again with pleasure. Thanks for the feedback