Excel VBA создает гиперссылку на ту же ячейку

Question

У меня есть лист со строкой «Заголовок», повторяющейся несколько раз в столбце B. Для каждого экземпляра Заголовка я хочу поместить гиперссылку на одну и ту же ячейку в строке значения непосредственно под ней (то есть, если заголовок находится в B1Я хотел бы гиперссылку в B2).

Так что, если бы гиперссылка была в B2 эффективно, она бы ничего не делала, кроме как говорила бы о той же ячейке при нажатии.

Однако мне нужно экстенсируемое значение вячейка B2 не изменится, все, что произойдет, будет переход от обычного значения к значению с гиперссылкой.

Ниже приведено то, что я придумал до сих пор, имейте в виду, что я довольно новичок в VBA, поэтому указатели ценятся.

Sub RunThis()
    'Declare workbook and worksheets:
    Dim mainFile As Workbook, titleDetailSheet As Worksheet    
    Set mainFile = ActiveWorkbook    
    Set titleDetailSheet = mainFile.Sheets("Title Detail")
    Dim searchString As String

    searchString = "Title"

    For r = 1 To 200
        If titleDetailSheet.Range("B" & r) = searchString Then
            titleDetailSheet.Range("B" & r + 1) = **'ActiveSheet.Hyperlinks.Add     Anchor:=Selection, Address:="", SubAddress:=titleDetailSheet.Name & "!A1", TextToDisplay:="Title"**
        End If
    Next r
End Sub

Я не уверен, какой будет правильный синтаксис для жирного шрифта.

Answer 1

HyperlinkBColumn

В

Set mainFile = ActiveWorbook

вы ошиблись написанием Activeworkbook.

Часть

SubAddress:=titleDetailSheet.Name & "!A1"

сложная:

SubAddress:="'" & titleDetailSheet.Name & "'!A1"

Ваши переменные имеют длину в милях.Попробуйте сократить их.

Option Explicit
'With Project ==================================================================
'  .Title: HyperlinkBColumn
'  .Author: YMG
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  With .Contents
'    Sub HyperlinkBColumn
'  End With
'===============================================================================
'
'-------------------------------------------------------------------------------
Sub HyperlinkBColumn()
'
'Description:
'  Loops through a specified column and when a specified value is found, puts
'  a hyperlink in the cell below.
'Arguments
'  None
'Returns
'  Hyperlinks on worksheet, Debugging info in the Immediate Window
'
'--Customize BEGIN ---------------------
  Const cWsName As String = "Title Detail"
  Const cSearch As String = "Title"
   Const cRow1 As Integer = 1
      Const cRow2 As Long = 200
     Const cCol As String = "B"
  Const cHeader As String = "Processing rows..." 'Immdediate Window
  Const cFooter As String = "...finished processing." 'Immediate Window
'--Customize END -----------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Dim oWb As Workbook
  Dim oWs As Worksheet
  Dim rCell1 As Range
  Dim rCell2 As Range
  Dim iR As Integer
  Dim strText As String
  Dim strAddr As String
  Dim str1 As String 'Immediate Window
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Set oWb = ActiveWorkbook
  Set oWs = oWb.Worksheets(cWsName)
  For iR = cRow1 To cRow2
    Set rCell1 = oWs.Range(cCol & iR)
    Set rCell2 = oWs.Range(cCol & iR + 1)
    strText = rCell2.Text 'What's written in the cell.
    strAddr = rCell2.Address 'The address e.g. B1, B13 ...
    If rCell1 = cSearch Then
      If strText <> "" Then
        'Anchor is the place where to put the hyperlink, cell or object.
        'Notice the single quotes (') in the SubAddress.
        'Readability is very important, notice every argument on its own line.
        'It's much easier to find a mistake.
        rCell2.Hyperlinks.Add _
        Anchor:=rCell2, _
        Address:="", _
        SubAddress:="'" & oWs.Name & "'!" & strAddr, _
        TextToDisplay:=strText 'The same text as requested
        str1 = str1 & vbCrLf & iR & ". " & rCell1.Address & " " _
          & strText & " - at " & strAddr 'Immediate Window
       Else
        'Put in here what to do if the cell below the Title cell is empty.
        'I've chosen to skip the line.
      End If
    End If
  Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    str1 = cHeader & str1 & vbCrLf & cFooter 'Immediate Window
    Debug.Print str1 'Immediate Window
'
End Sub
'-------------------------------------------------------------------------------
'
'With Idea Source --------------------------------------------------------------
'  .Title: Excel VBA creating a Hyperlink to the same cell
'  .TitleURL: /11494685/excel-vba-sozdaet-giperssylku-na-tu-zhe-yacheiku
'  .Author: Nayan
'  .AuthorURL: https://stackoverflow.com/users/10416060/nayan
'End With ----------------------------------------------------------------------
'
'End With ======================================================================

Только один вопрос: зачем создавать гиперссылку, указывающую на ту же ячейку, где она находится?

Answer 2

вам понадобится что-то вроде этого

If titleDetailSheet.Range("B" & r) = searchString Then
    mainFile.ActiveSheet.Hyperlinks.Add _
         Anchor:=titleDetailSheet.Range("B" & r + 1), _
         Address:="", _
         SubAddress:="'" & titleDetailSheet.Name & "'!" & titleDetailSheet.Range("B" & r).Address, _
         TextToDisplay:=titleDetailSheet.Range("B" & r + 1).Value
End If

Пожалуйста, посмотрите, можете ли вы понять синтаксис, и просто спросите меня, есть ли неясные пункты.^ - ^ * * 1004