时间戳

首页 > 解决方案 > VBA 用户输入、复制公式和创建工作表的超链接

excel - VBA 用户输入、复制公式和创建工作表的超链接

问题描述

我有一个按钮，要求用户输入和单元格选择。该按钮还会在表格底部插入一个新行，并且应该向下复制公式，但事实并非如此。当用户输入字符串时，它应该匹配工作簿中已经存在的工作表。所以我想将新单元格与现有工作表的名称匹配以创建超链接。那也不行。 

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

标签： excelvbainputbox

解决方案

超链接子地址需要指向工作表上的单元格，如“工作表名称”！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

推荐阅读