Question

这有点模糊，因为我真的不知道从哪里开始。

我有一个动态数据库输出，如下所示：

Link1
Link2
Link3,Link4,Link5
Link6
Link7,Link8

每个链接代表我的电子表格中的其他位置。我有VBA代码可以运行并根据单元格值生成超链接，但显然这对包含多个链接的单元格不起作用。

我对此问题的看法是，我在后台有一个用户表单，当活动单元格包含“，”时会显示。

我需要做的是从Active Cell创建一个数组：

arr = Split(ActiveCell.Value, ",")

然后填充一个表格，然后可以将其编程为使用后续列表作为超链接。

我很抱歉我没有为此做过更多的基础工作。我很难找到任何现有的相关信息。

这里的关键问题是：

最好使用哪种UserForm？（ComboBox / ListBox？）
如何根据活动单元格的内容使表单可见。
如何将Active Cell的内容添加到表单中。
如何将表单中的项目链接到单元格引用。（关于这一点，每个'Linkx'应链接到电子表格中某个包含完全相同值的其他单元格。）

非常感谢任何建议。大卫

更新

我想出了以下内容来创建列表：

Option Explicit
Public Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Cancel = True
Dim arr As Variant
Dim arrin As Variant
Dim ArrLen As Integer
Dim i As Integer

If InStr(1, ActiveCell.Value, ",", vbTextCompare) <> 0 Then
    If InStr(1, ActiveCell.Value, "|", vbTextCompare) <> 0 Then
        ListBoxDictionary.RemoveAll
        arr = Split(ActiveCell.Value, ",")
        ArrLen = Application.CountA(arr)
        If UserForm1.Visible = True Then
            UserForm1.ListBox1.Clear
        End If
        For i = 0 To ArrLen - 1
            arrin = Split(arr(i), "|")
            UserForm1.ListBox1.AddItem arrin(1) & " - " & Left(arrin(0), InStr(1, arrin(0), "]"))
            ListBoxDictionary(arrin(1) & " - " & Left(arrin(0), InStr(1, arrin(0), "]"))) = arrin(0)
        Next i

        If UserForm1.Visible = False Then
            UserForm1.Show
            UserForm1.Caption = Cells(1, ActiveCell.Column).Value
        End If
    End If
End If


End Sub

我现在需要确定一种使用“选定项目”在工作簿中查找匹配单元格的方法。在所有可见工作表中，此匹配单元格可能位于列“D”的已使用单元格中。

更新2：

对于遇到类似问题的人来说，这是我的解决方案：

Global ListBoxDictionary As New Dictionary
Public Sub ListBox1_Click()
    Dim WS_Count As Integer
    Dim WS_No
    Dim Fnd As Integer
    Dim LstItem As String

    WS_Count = ActiveWorkbook.Worksheets.Count
    Fnd = 0
    LstItem = ListBoxDictionary.Item(ListBox1.Value)

    For WS_No = 1 To WS_Count
        If Fnd <> 1 Then
            If Sheets(WS_No).Name <> "Sheet2" Then
                c = Application.Match(LstItem, Sheets(WS_No).Range("D:D"), 0)
                If IsError(c) Then
                Else
                    Fnd = 1
                    UserForm1.Hide
                    Sheets(WS_No).Activate
                    Sheets(WS_No).Cells(c, "D").Activate
                    UserForm1.ListBox1.Clear
                End If
            End If
        End If
    Next WS_No
End Sub

使用字典的原因是因为我希望能够更改链接中显示的文本，同时保留我需要搜索的字符串。

感谢您的投入。大卫

Answer 1

将名为“lstLinks”的表单列表框添加到工作表中，并将其“宏”设置为PickedOne。从您的问题中不清楚您是如何实际导航到“链接”范围的。

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Worksheet_BeforeDoubleClick Target, False
End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim lst As Object, arr, x
Dim lstObj As Object

    Set Target = Target.Cells(1) 'ignore multi-cell selections
    Set lst = Me.Shapes("lstLinks")

    If InStr(Target.Value, ",") > 0 Then
        lst.Visible = True
        lst.Top = Target.Top + Target.RowHeight
        lst.Left = Target.Left
        arr = Split(Target.Value, ",")
        Set lstObj = lst.OLEFormat.Object
        Do While lstObj.ListCount > 0
            lstObj.RemoveItem 1
        Loop
        For x = LBound(arr) To UBound(arr)
            lstObj.AddItem Trim(arr(x))
        Next x
        Cancel = True
    Else
        lst.Visible = False
    End If
End Sub

Sub PickedOne()
    Dim lst, v
    Set lst = Me.Shapes(Application.Caller)
    v = lst.OLEFormat.Object.List(lst.OLEFormat.Object.ListIndex)
    lst.Visible = False
    ShowItem v
End Sub

Sub ShowItem(v)
    MsgBox "Showing item: " & v
End Sub

Answer 2

以下命令从逗号分隔的字符串创建列表并将其放入：

（请注意，我的链接列表现已演变为：

Link1|Description
Link2|Description,Link3|Description
Link4|Description

等）

Option Explicit
Public Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Cancel = True
Dim arr As Variant
Dim arrin As Variant
Dim ArrLen As Integer
Dim i As Integer

If InStr(1, ActiveCell.Value, ",", vbTextCompare) <> 0 Then
    If InStr(1, ActiveCell.Value, "|", vbTextCompare) <> 0 Then
        ListBoxDictionary.RemoveAll
        arr = Split(ActiveCell.Value, ",")
        ArrLen = Application.CountA(arr)
        If UserForm1.Visible = True Then
            UserForm1.ListBox1.Clear
        End If
        For i = 0 To ArrLen - 1
            arrin = Split(arr(i), "|")
            UserForm1.ListBox1.AddItem arrin(1) & " - " & Left(arrin(0), InStr(1, arrin(0), "]"))
            ListBoxDictionary(arrin(1) & " - " & Left(arrin(0), InStr(1, arrin(0), "]"))) = arrin(0)
        Next i

        If UserForm1.Visible = False Then
            UserForm1.Show
            UserForm1.Caption = Cells(1, ActiveCell.Column).Value
        End If
    End If
End If


End Sub

除此之外，这是用于超链接的列表框本身的代码：

Global ListBoxDictionary As New Dictionary
Public Sub ListBox1_Click()
    Dim WS_Count As Integer
    Dim WS_No
    Dim Fnd As Integer
    Dim LstItem As String

    WS_Count = ActiveWorkbook.Worksheets.Count
    Fnd = 0
    LstItem = ListBoxDictionary.Item(ListBox1.Value)

    For WS_No = 1 To WS_Count
        If Fnd <> 1 Then
            If Sheets(WS_No).Name <> "Sheet2" Then
                c = Application.Match(LstItem, Sheets(WS_No).Range("D:D"), 0)
                If IsError(c) Then
                Else
                    Fnd = 1
                    UserForm1.Hide
                    Sheets(WS_No).Activate
                    Sheets(WS_No).Cells(c, "D").Activate
                    UserForm1.ListBox1.Clear
                End If
            End If
        End If
    Next WS_No
End Sub

使用字典的原因是因为我希望能够更改链接中显示的文本，同时保留我需要搜索的字符串。

从上面来看，这是我能想到的最佳答案。

感谢您的其他建议。大卫。

VBA Excel包含Array的activecell的超链接列表

2 个答案: