Question

我没有找到宏来实现我的目标，现在我已经筋疲力尽了我的搜索能力。

我有两个工作表 1 - 数据表 2 - AllHeaders

我希望宏从工作表中复制第1行数据＆＃34; DataSheet＆＃34;，将其转置并粘贴到工作表中＃34; AllHeaders＆＃34;并创建指向该标题的超链接。比你！

这是录制的宏，但我只记录了两个列标题超链接，因为有数千个标题手动完成此操作需要一天。

  Sub Macro1()
 '
 ' Macro1 Macro
 '

 '
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("AllHeaders").Select
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=True
Range("B5").Select
Application.CutCopyMode = False
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
    "DataSheet!A1", TextToDisplay:="responseid"
Range("B6").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
    "DataSheet!B1", TextToDisplay:="respid"
End Sub

Answer 1

尝试循环播放。我目前无法对此进行测试，但它应该是您需要的大部分内容：

Sub CreateHeaders()
    Dim wsData as Worksheet
    Dim wsHeaders as Worksheet
    Dim headerRange as Range
    Dim header as Range
    Dim i as Long: i=0
    Dim anchor as Range
    DIm subAddr as String

    Set wsData = Worksheets("DataSheet")
    Set wsHeaders = Worksheets("AllHeaders")
    Set headerRange = wsData.Range("A1", wsData.Range("A1").End(xlToRight))
    Set anchor = wsHeaders.Range("B5")  '## begin inserting the hyperlinks at B5

    For each header in headerRange  '## iterate over each cell in the header row
        subAddr = "'" & wsData.Name & "'!" & header.Address
        With wsHeaders
            .Hyperlinks.Add Anchor:=anchor, Address:="", SubAddress:= _
                 subAddr, TextToDisplay:=header.Value
        End With
        i = i+1  
        Set anchor = anchor.Offset(i,0)  '## increment the location of the next hyperlink, to the next row
    Next

End Sub

将第1行数据（标题）列入另一个工作表中的列并创建HyperLink

1 个答案: