用于查找名称在A列中输入并将其超链接的表格的代码

时间:2016-03-12 09:00:11

标签: excel vba excel-vba hyperlink

我正在创建一个程序,它将创建新的工作表并使它们成为超链接。 目前我正面临一个小问题。

这是我的代码:

Dim wks As Worksheet
Dim row2 As Integer

row2 = 10

For Each wks In Worksheets
    Select Case LCase(wks.Name)
    Case "summary-nca", "summary-gh-sample", "summary-ch-sample", "coa ledger"
        Debug.Print "Skipping " & wks.Name
    Case Else
        wks.Hyperlinks.Add ws.Cells(row2, 1), "", "'" & wks.Name & "'!A10", , wks.Name

        row2 = row2 + 1
    End Select
Next wks

在此代码中,它会跳过某些特定的工作表。我需要修改,以便在工作表的A列中有一个列表。程序应该将列图与工作簿中的工作表名称匹配,然后将其超链接。

2 个答案:

答案 0 :(得分:1)

我将您的问题解释为超链接应该在列表中。

Sub hlws()
    Dim wks As Worksheet, mtch As Variant

    On Error Resume Next
    With Worksheets("Sheet1")
        With .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp))  '<~~ define the WS list range!!!
            .Hyperlinks.Delete
            For Each wks In Worksheets
                mtch = Application.Match(wks.Name, .Columns(1), 0)
                If Not IsError(mtch) Then
                    .Hyperlinks.Add Anchor:=.Cells(mtch, "A"), _
                                    Address:="", _
                                    SubAddress:=Chr(39) & .Cells(mtch, "A").Value2 & "'!$A$1", _
                                    TextToDisplay:=.Cells(mtch, "A").Value2
                End If
            Next wks
        End With
    End With
End Sub

这大致重复了您自己的代码,添加了WorksheetFunction object MATCH function,验证了工作表在列表中的存在。在运行该过程之前,请确保正确设置列表范围。

答案 1 :(得分:0)

这段代码对我有用。它会将超链接列表写入一个名为&#34; Main&#34;的选项卡,您可以随时更改,或者只是放入您的工作表对象的值,并且#34; ws&#34; (这不会显示在您的代码中,也不是声明):

Option Explicit

Sub Macro1()

    Dim wks As Worksheet
    Dim row2 As Integer
    Dim ws As Worksheet

    row2 = 10
    Set ws = Sheets("Main")

    For Each wks In Worksheets

        Select Case LCase(wks.Name)

            Case "main", "summary-gh-sample", "summary-ch-sample", "coa ledger"

                Debug.Print "Skipping " & wks.Name

            Case Else

                wks.Hyperlinks.Add ws.Cells(row2, 1), "", "'" & wks.Name & "'!A10", , wks.Name
                row2 = row2 + 1

            End Select

    Next wks

End Sub