Пользовательский ввод VBA, копирование формул и создание гиперссылки на лист - PullRequest
Новая
       22

Пользовательский ввод VBA, копирование формул и создание гиперссылки на лист

0 голосов
/ 27 февраля 2020

У меня есть кнопка, которая запрашивает ввод пользователя и выбор ячейки. Кнопка также вставляет новую строку внизу таблицы и должна копировать формулы вниз, но это не так. Когда пользователь вводит строку, она должна соответствовать уже существующему листу в книге. Поэтому я хочу сопоставить новую ячейку с именем существующего листа, чтобы создать гиперссылку. Это тоже не работает. 

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

1 Ответ

1 голос
/ 28 февраля 2020

Подадрес гиперссылки должен быть на ячейке на листе, как «Имя листа»! 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
...