Question

我的数据表（“ srData”）是使用用户窗体填充的数据透视表。所有数据在数据表的A列中都有唯一的ID。在userform复选框中选中，这将更改单元格，在K：AB列中，内部颜色为white（2），否则内部颜色为grey（15）在我的主工作表（“配方”）中，基于选择唯一ID（即SR-1，SR-2，SR-3等）的下拉框（C6）的值，如果interior.colorindex = 2，则从第20行开始在sheet（“ Formulier”）的A列中返回sheet（“ srData”）。单元格中的值从第20行开始在D列中返回。现在，在（“ srData”）的Y和Z列中，我放置了一个链接到PDF的超链接。（请参阅SR-4第一张图片）在Y和Z列中，在所有具有internal.colorindex = 2的单元格中总会有超链接。

现在我从工作表（“ Formulier”）的下拉列表中选择唯一ID时，我希望它返回活动的超链接，而不仅仅是现在的tekst。这可能吗？这是我用于返回标头和值的代码。该代码是由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

请先进行备份，然后尝试一下：

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

Answer 2

通常，将字符串转换为超链接的方式如下：

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中的网页的链接。您可以根据自己的需要进行修改。

如何基于下拉选择将超链接返回到另一个工作表

2 个答案: