0

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

我有两个工作表 1 - DataSheet 2 - AllHeaders

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

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

  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
4

1 回答 1

0

尝试循环执行此操作。我目前无法对此进行测试，但它应该是您最需要的：

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
于 2013-07-28T20:23:20.393 回答