我的数据表(“ 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
`
答案 0 :(得分:0)
请先进行备份,然后尝试一下:
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
答案 1 :(得分:0)
通常,将字符串转换为超链接的方式如下:
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中的网页的链接。 您可以根据自己的需要进行修改。