Как вернуть гиперссылку на другой лист на основе выпадающего списка

Question

Моя таблица данных ("srData") - это сводная таблица, которая заполняется с использованием пользовательской формы.Все данные имеют уникальный идентификатор в столбце A таблицы данных.В пользовательской форме установлены флажки, которые изменят ячейки, в столбцах K: AB, цвет салона на белый (2), иначе цвет салона серый (15) На моем основном рабочем листе ("Formulier "), на основе значения раскрывающегося списка (C6), где выбран уникальный идентификатор (т. Е. SR-1, SR-2, SR-3 и т. Д.), Заголовков из листа (" srData ")возвращаются в столбце A листа («Formulier»), начиная со строки 20, если interior.colorindex = 2.Значения в ячейках возвращаются в столбце D, начиная со строки 20. Теперь в столбцах Y и Z из ("srData") я разместил гиперссылку, которая ссылается на PDF (см. SR-4 первое изображение) В столбцах Y и Z всегда будут гиперссылки в ячейках с interior.colorindex = 2.

Когда я сейчас выберу уникальный идентификатор из выпадающего списка («Formulier»), я бынравится возвращать активную гиперссылку, а не просто текст, как сейчас.Это возможно?Это код, который у меня есть для возврата заголовка и значений.Код был создан VBasic2008, так что кредит ему.`

Option Explicit
Public Const CriteriaCell As String = "C6"    ' Criteria Cell Range Address

Sub ColorSearch()

' Source
Const cSource As Variant = "srData"       ' Worksheet Name/Index
Const cCriteriaColumn As Variant = "A"    ' Criteria Column Letter/Number
Const cColumns As String = "K:AB"         ' Columns Range Address
Const cHeaderRow As Long = 1              ' Header Row Number
Const cColorIndex As Long = 2             ' Criteria Color Index (2-White)
' Target
Const cTarget As Variant = "Formulier"    ' Worksheet Name/Index
Const cFr As Long = 20                    ' First Row Number
Const cCol As Variant = "A"               ' Column Letter/Number
Const cColVal As Variant = "D"            ' Value Column Letter/Number

Dim Rng As Range      ' Source Found Cell Range
Dim vntH As Variant   ' Header Array
Dim vntC As Variant   ' Color Array
Dim vntV As Variant   ' Value Array
Dim vntT As Variant   ' Target Array
Dim vntTV As Variant  ' Target Value Array
Dim i As Long         ' Source/Color Array Column Counter
Dim k As Long         ' Target Array Row Counter
Dim sRow As Long      ' Color Row
Dim SVal As String    ' Search Value
Dim Noe As Long       ' Source Number of Elements

' Write value from Criteria Cell Range to Search Value.
SVal = ThisWorkbook.Worksheets(cTarget).Range(CriteriaCell)

' In Source Worksheet
With ThisWorkbook.Worksheets(cSource)
    ' Search for Search Value in Source Criteria Column and create
    ' a reference to Source Found Cell Range.
    Set Rng = .Columns(cCriteriaColumn) _
            .Find(SVal, , xlValues, xlWhole, , xlNext)
    ' Check if Search Value not found. Exit if.
    If Rng Is Nothing Then Exit Sub
    ' Write row of Source Found Cell Range to Color Row.
    sRow = Rng.Row
    ' Release rng variable (not needed anymore).
    Set Rng = Nothing
    ' In Source Columns
    With .Columns(cColumns)
        ' Copy Header Range to Header Array.
        vntH = .Rows(cHeaderRow)
        ' Copy Color Range to Color Array.
        vntC = .Rows(sRow)
        ' *** Copy Color Range to Value Array.
        ' Note: The values are also written to Color Array, but are
        '       later overwritten with the Color Indexes.
        vntV = .Rows(sRow)
        ' Write number of columns in Source Columns to Source Number
        ' of Elements.
        Noe = .Columns.Count
        ' Loop through columns of Color Range/Array.
        For i = 1 To Noe
            ' Write current ColorIndex of Color Range to current
            ' element in Color Array.
            vntC(1, i) = .Cells(sRow, i).Interior.ColorIndex
        Next
    End With
End With
' Resize Target Array to Number of Elements rows and one column.
ReDim vntT(1 To Noe, 1 To 1)
' *** Resize Target Value Array to Number of Elements rows and one column.
ReDim vntTV(1 To Noe, 1 To 1)
' Loop through columns of Color Array.
For i = 1 To Noe
    ' Check if current value in Color Array is equal to Criteria
    ' Column Index.
    If vntC(1, i) = cColorIndex Then
        ' Count row in Target Array.
        k = k + 1
        ' Write value of current COLUMN in Header Array to
        ' element in current ROW of Target Array.
        vntT(k, 1) = vntH(1, i)
        ' *** Write value of current COLUMN in Value Array to
        ' element in current ROW of Target Value Array.
        vntTV(k, 1) = vntV(1, i)
    End If
Next

' Erase Header and Color Arrays (not needed anymore).
Erase vntH
Erase vntC
Erase vntV '***

' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget)
    ' Calculate Target Range by resizing the cell at the intersection of
    ' Target First Row and Target Column, by Number of Elements.
    ' Copy Target Array to Target Range.
    .Cells(cFr, cCol).Resize(Noe) = vntT
    ' *** Calculate Target Value Range by resizing the cell at the
    ' intersection of Target First Row and Value Column, by Number of
    ' Elements.
    ' Copy Target Value Array to Target Value Range.
    .Cells(cFr, cColVal).Resize(Noe) = vntTV
End With

End Sub

`

Answer 1

Как правило, вы можете преобразовать строку в гиперссылку следующим образом:

Sub text2Hyperlink()
    Dim sht As Worksheet
    Dim URL As String
    Dim filePath As String
    Set sht = ThisWorkbook.Worksheets("Worksheet Name") ' whichever worksheet you're working with
    filePath = ".....\Something.pdf"
    URL = "https://www.google.com/"
    sht.Hyperlinks.Add sht.Range("A1"), filePath
    sht.Hyperlinks.Add sht.Range("A2"), URL
End Sub

Это берет некоторый текст, сохраненный в строке, и назначает его как гиперссылку в ячейке.Он работает как для веб-сайтов, так и для файлов

В этом случае вы получите ссылку на файл в ячейке A1 и ссылку на веб-страницу в ячейке A2.Вы можете изменить это в соответствии со своими потребностями.

Answer 2

Сделайте резервную копию и попробуйте:

Option Explicit
Public Const CriteriaCell As String = "C6"    ' Criteria Cell Range Address

Sub ColorSearch()

' Source
Const cSource As Variant = "srData"       ' Worksheet Name/Index
Const cCriteriaColumn As Variant = "A"    ' Criteria Column Letter/Number
Const cColumns As String = "K:AB"         ' Columns Range Address
Const cHeaderRow As Long = 1              ' Header Row Number
Const cColorIndex As Long = 2             ' Criteria Color Index (2-White)
' Target
Const cTarget As Variant = "Formulier"    ' Worksheet Name/Index
Const cFr As Long = 20                    ' First Row Number
Const cCol As Variant = "A"               ' Column Letter/Number
Const cColVal As Variant = "D"            ' Value Column Letter/Number

Dim Rng As Range      ' Source Found Cell Range

Dim targetCell As Range ' Cell to add hyperlink

Dim vntH As Variant   ' Header Array
Dim vntC As Variant   ' Color Array
Dim vntV As Variant   ' Value Array
Dim vntHy As Variant   ' Hyperlink Array (*)
Dim vntT As Variant   ' Target Array
Dim vntTV As Variant  ' Target Value Array
Dim vntTH As Variant    ' Target Hyperlink
Dim i As Long         ' Source/Color Array Column Counter
Dim k As Long         ' Target Array Row Counter
Dim sRow As Long      ' Color Row
Dim SVal As String    ' Search Value
Dim Noe As Long       ' Source Number of Elements

Dim hyperlinkCounter As Long     ' Counter for assigning hyperlink

' Write value from Criteria Cell Range to Search Value.
SVal = ThisWorkbook.Worksheets(cTarget).Range(CriteriaCell)

' In Source Worksheet
With ThisWorkbook.Worksheets(cSource)
    ' Search for Search Value in Source Criteria Column and create
    ' a reference to Source Found Cell Range.
    Set Rng = .Columns(cCriteriaColumn) _
            .Find(SVal, , xlValues, xlWhole, , xlNext)
    ' Check if Search Value not found. Exit if.
    If Rng Is Nothing Then Exit Sub
    ' Write row of Source Found Cell Range to Color Row.
    sRow = Rng.Row
    ' Release rng variable (not needed anymore).
    Set Rng = Nothing
    ' In Source Columns
    With .Columns(cColumns)
        ' Copy Header Range to Header Array.
        vntH = .Rows(cHeaderRow)
        ' Copy Color Range to Color Array.
        vntC = .Rows(sRow)
        ' *** Copy Color Range to Value Array.
        ' Note: The values are also written to Color Array, but are
        '       later overwritten with the Color Indexes.
        vntV = .Rows(sRow)
        ' Write number of columns in Source Columns to Source Number
        ' of Elements.
        Noe = .Columns.Count

        ' Redimension
        ReDim vntHy(1 To 1, 1 To Noe)

        ' Loop through columns of Color Range/Array.
        For i = 1 To Noe
            ' Write current ColorIndex of Color Range to current
            ' element in Color Array.
            vntC(1, i) = .Cells(sRow, i).Interior.ColorIndex
            If .Cells(sRow, i).Hyperlinks.Count > 0 Then

                vntHy(1, i) = .Cells(sRow, i).Hyperlinks(1).Address
            End If
        Next
    End With
End With
' Resize Target Array to Number of Elements rows and one column.
ReDim vntT(1 To Noe, 1 To 1)
' *** Resize Target Value Array to Number of Elements rows and one column.
ReDim vntTV(1 To Noe, 1 To 1)

' Resize target hyperlink array
ReDim vntTH(1 To Noe, 1 To 1)



' Loop through columns of Color Array.
For i = 1 To Noe
    ' Check if current value in Color Array is equal to Criteria
    ' Column Index.
    If vntC(1, i) = cColorIndex Then
        ' Count row in Target Array.
        k = k + 1
        ' Write value of current COLUMN in Header Array to
        ' element in current ROW of Target Array.
        vntT(k, 1) = vntH(1, i)
        ' *** Write value of current COLUMN in Value Array to
        ' element in current ROW of Target Value Array.
        vntTV(k, 1) = vntV(1, i)

        ' Add hyperlink to array
        vntTH(k, 1) = vntHy(1, i)

    End If
Next

' Erase Header and Color Arrays (not needed anymore).
Erase vntH
Erase vntC
Erase vntV '***

' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget)
    ' Calculate Target Range by resizing the cell at the intersection of
    ' Target First Row and Target Column, by Number of Elements.
    ' Copy Target Array to Target Range.
    .Cells(cFr, cCol).Resize(Noe) = vntT
    ' *** Calculate Target Value Range by resizing the cell at the
    ' intersection of Target First Row and Value Column, by Number of
    ' Elements.
    ' Copy Target Value Array to Target Value Range.
    .Cells(cFr, cColVal).Resize(Noe) = vntTV

    ' Assign hyperlinks to cells
    For Each targetCell In .Cells(cFr, cColVal).Resize(Noe)

        ' Remove previous hyperlinks
        If targetCell.Hyperlinks.Count > 0 Then

            targetCell.Hyperlinks.Item(1).Delete

        End If

        ' Add new hyperlink
        If vntTH(hyperlinkCounter + 1, 1) <> vbNullString Then

            ThisWorkbook.Worksheets(cTarget).Hyperlinks.Add targetCell, vntTH(hyperlinkCounter + 1, 1)

        End If



        hyperlinkCounter = hyperlinkCounter + 1
    Next targetCell

End With

End Sub