CODEWITHSUNDEEP
excelvbainputbox
DeAnna
DeAnna

Reputation: 402

VBA user input, copy formulas and create hyperlink to sheet

I have a button that asks for user input and a cell selection. The button also inserts a new row at the bottom of the table and is supposed to copy formulas down, but its not. When the user inputs the string, it should match an already existing sheet in the workbook. So I want to match the new cell with the name of existing sheet to create a hyperlink. That's not working either. 

Private Sub NewWellButton_Click()
  Dim well As Variant
  Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
   ' Copy formula from cell above
  Rows(Selection.Row).Insert Shift:=xlDown
  ActiveCell.EntireRow.Copy
  ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteFormulas
  Application.CutCopyMode = xlCopy
  Dim ChosenRange As Range
  Set ChosenRange = Application.InputBox(prompt:="Select the next empty cell in column A to input the well name.", Type:=8)
  well = Application.InputBox("Enter the new well name", Title:="New Well")
  ChosenRange.Value = UCase(well)
  ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=well
  On Error Resume Next
  MsgBox "Well names do not match to create hyperlink"
  Exit Sub
End Sub

Upvotes: 0

Views: 195

Answers (1)

CDP1802
CDP1802

Reputation: 16184

The hyperlink SubAddress need to be to a cell on the sheet like 'Sheet Name'!A1.

Option Explicit
Private Sub NewWellButton_Click()

    Dim wb As Workbook, ws As Worksheet, wsNew As Worksheet, sht As Worksheet
    Dim sWellName As String, lastCell As Range, bExists As Boolean, s As String
    Set wb = ActiveWorkbook
    Set ws = wb.Sheets(1)

    sWellName = Application.InputBox("Enter the new well name", Title:="New Well")

    If Len(sWellName) = 0 Then
        MsgBox "Well Name blank", vbExclamation
        Exit Sub
    Else
       For Each sht In wb.Sheets
           If sht.Name = sWellName Then bExists = True
       Next
    End If

    If bExists = False Then
        s = "Sheet [" & sWellName & "] does not exist, do you want to create it ?"
        If vbYes = MsgBox(s, vbYesNo, "Not Found") Then
            Set wsNew = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            wsNew.Name = sWellName
            ws.Select
        End If
    End If

    ' copy
    Set lastCell = ws.Cells(Rows.Count, 1).End(xlUp)
    lastCell.EntireRow.Copy

    ' paste below
    Set lastCell = lastCell.Offset(1, 0)
    lastCell.PasteSpecial xlPasteFormulas
    Application.CutCopyMode = False

    ' add link
    With lastCell
       .Value = UCase(sWellName)
       .Hyperlinks.Add Anchor:=lastCell, Address:="", SubAddress:="'" & sWellName & "'!A1"
    End With

End Sub

Upvotes: 1

Related Questions