ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 7536|回复: 16

自动插入超链接怎么作啊?望高人指点

[复制链接]

TA的精华主题

TA的得分主题

发表于 2005-12-3 11:56 | 显示全部楼层 |阅读模式

我现在作剪报,每一篇都是以SGM News Clipping from China Top 开头,我现在要在每篇剪报的开头加一个书签,然后在“Top”上加上超链接连到文档开头处目录中对应的书签。自动加书签的程序我已经写好了,目录中按照a1,a2,a3……这样的顺序排列,剪报中按照b1,b2,b3……这样的顺序排列。但是加超链接的程序我不会作,下面是加书签的程序,希望高人帮我给它加上插入超链接的功能。

Sub bookmarkb()
Application.ScreenUpdating = False
Dim k As Integer, m As String, findchar As String
findchar = "sgm news clipping from china"
k = 1
With ActiveDocument.Content.find
Do While .Execute(findtext:=findchar) = True
m = k
Selection.find.Execute
ActiveDocument.Bookmarks.Add Name:="b" & m
k = k + 1
Loop
End With
Application.ScreenUpdating = True
End Sub

我上传了一个文件示例。

JcZ102uD.rar (13.05 KB, 下载次数: 30)
[此贴子已经被作者于2005-12-3 15:17:55编辑过]

TA的精华主题

TA的得分主题

发表于 2005-12-3 14:12 | 显示全部楼层
不是太明白,传一份示例文档上来看看

TA的精华主题

TA的得分主题

 楼主| 发表于 2005-12-3 15:23 | 显示全部楼层
示例文档已上传,大侠帮我看看吧。还有一个问题:我现在自动插入书签的命名是按b1,b2,......b100这样排的,怎样改成按b001,b002,......b100这样排?
[此贴子已经被作者于2005-12-3 15:28:30编辑过]

TA的精华主题

TA的得分主题

发表于 2005-12-3 22:37 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

试着做了一个:

Option Explicit
Sub bookmarkb()
Application.ScreenUpdating = False
Dim k As Integer, m As String, findStr As String
Dim myRange As Range, tipText As String
SendKeys "%{HOME}"
findStr = "SGM News Clipping from China"
Selection.Find.ClearFormatting
k = 1
With Selection.Find
Do While .Execute(findText:=findStr)
m = String(3 - Len(CStr(k)), "0") & CStr(k)
ActiveDocument.Bookmarks.Add Name:="b" & m
k = k + 1
Set myRange = Tables(1).Cell(k, 5).Range.Paragraphs(1).Range
Set myRange = Range(myRange.Start, myRange.End - 1)
tipText = myRange.Text
ActiveDocument.Hyperlinks.Add Anchor:=myRange, Address:="", _
SubAddress:="b" & m, ScreenTip:="", TextToDisplay:=tipText
Loop
End With
Application.ScreenUpdating = True
End Sub


TA的精华主题

TA的得分主题

 楼主| 发表于 2005-12-3 23:28 | 显示全部楼层

谢谢gues1688了,不过现在有两个问题:

1.插入的书签b系列书签并没有插入到找到的"SGM News Clipping from China"上,而是都插入到了光标当前位置。

2.目录中加入标签和超链接我都做好了,关键是每篇剪报第一行中给那个“top”加超链接我还不会。

目前完成的代码如下:

1)给目录加书签:

Sub bookmarkA()
Application.ScreenUpdating = False
Dim mystr As String, i As Integer, k As Integer, bkmark As Bookmark, m As String
Set mydoc1 = ActiveDocument
totalnumber = mydoc1.Bookmarks.Count
For i = totalnumber To 1 Step -1
mydoc1.Bookmarks(i).Delete
Next i
k = 1
For Each Row In mydoc1.Tables(1).Rows
m = k - 1
mydoc1.Bookmarks.Add Name:="a" & m, Range:=mydoc1.Tables(1).Rows(k).Cells(1)
k = k + 1
Next
Application.ScreenUpdating = True
End Sub
2)给目录加超链接:

Sub hyA()
Application.ScreenUpdating = False
Dim mystr As String, i As Integer, k As Integer, m As String, x As Integer
Set mydoc1 = ActiveDocument
Set mytable = mydoc1.Tables(1)
i = mytable.Rows.Count
'MsgBox i
For k = 2 To i
x = k - 1
mystr = mydoc1.Range(mytable.Cell(k, 5).Range.Start, mytable.Cell(k, 5).Range.End - 1)
'MsgBox mystr
mydoc1.Range(mytable.Cell(k, 5).Range.Start, mytable.Cell(k, 5).Range.End - 1).Select
With Selection
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
SubAddress:="b" & x, ScreenTip:="", TextToDisplay:=mystr
End With
Next k
Application.ScreenUpdating = True
End Sub

上面两个不管怎么说还是能运行的,下面两个就是问题所在了:

3)给每篇剪报加书签,但是书签都没有加到正确的位置上:

Sub bookmarkb()
Application.ScreenUpdating = False
Dim k As Integer, m As String, findchar As String, mystr As String
findchar = "SGM News Clipping from China"
k = 1
With ActiveDocument.Content.find
Do While .Execute(findtext:=findchar) = True
m = String(3 - Len(CStr(k)), "0") & CStr(k)
Selection.find.Execute
ActiveDocument.Bookmarks.Add Name:="b" & m
k = k + 1
Loop
End With
Application.ScreenUpdating = True
End Sub

4)给每篇剪报第一行的“top”加超链接,遇到两个问题:

a.找到每页第一行的“top”而不要其它位置的“top”

b.和第3)段代码的问题一样,插入的超链接都在当前光标处,而不是在找到的“top”处。

TA的精华主题

TA的得分主题

发表于 2005-12-4 00:27 | 显示全部楼层

搜索的代码不太对,试一下:

Sub bookmarkb()
Application.ScreenUpdating = False
Dim k As Integer, m As String, findchar As String, mystr As String
Application.Activate
SendKeys "^{HOME}", wait:=True
findchar = "SGM News Clipping from China"
k = 1
With Selection.Find
Do While .Execute(findtext:=findchar) = True
m = String(3 - Len(CStr(k)), "0") & CStr(k)
ActiveDocument.Bookmarks.Add Name:="b" & m
k = k + 1
Loop
End With
Application.ScreenUpdating = True
End Sub

从文档首部开始搜索,我只会使用sendkeys的方法,不知道是否有其它方法,vba我刚学,不太熟

TA的精华主题

TA的得分主题

发表于 2005-12-4 00:33 | 显示全部楼层
每页第1行的TOP,是不是可以通过搜索“SGM News Clipping from China Top”来定位?是否还有其它方法我也不知道

TA的精华主题

TA的得分主题

发表于 2005-12-4 06:51 | 显示全部楼层

Option Explicit
Sub InsertHyperlinker()
'以下代码完成的功能是在表格将自动插入书签和将指定单元格
'链接到TOP文本所在位置,并将TOP所在位置链接到表格指定单元格
'起始位置
Dim myTable As Table, myCol As Column, oCell As Cell
Dim RowId As Integer, cellRange As Range
Dim myRange As Range, TopCount As Integer, strFind As String
Dim TopRange As Range, BkName As String, HyBkName As String
strFind = "SGM News Clipping from China Top^p" '定义一个查找的字符串,为精确起见,加上段落标记
With ActiveDocument
If .Tables.Count < 1 Then Exit Sub '如果没有表格(目录),则退出运行
.Fields.Unlink '去除超链接,这是为确保查找的准确性
Set myTable = .Tables(1) '定义一个表格对象
Set myCol = myTable.Columns(1) '定义一个列对象
For Each oCell In myCol.Cells '遍历表格首行单元格
RowId = oCell.RowIndex '取得行号
If RowId > 1 Then '首行不进行运算处理
Set cellRange = .Range(oCell.Range.Start, oCell.Range.Start) '单元格开始位置
BkName = "A" & VBA.Format(RowId - 1, "000") '定义一个书签名,形如"A010"
.Bookmarks.Add Name:=BkName, Range:=cellRange '添加一个书签
End If
Next
Set myRange = .Content '定义一个RANGE对象,为主文档文字部分
With myRange.Find '查找
.ClearFormatting '清除格式
.Text = strFind
Do While .Execute And myRange.Hyperlinks.Count = 0 '如果找到没有超级链接的这个段落文本
TopCount = TopCount + 1 '计数
Set TopRange = myRange.Words(6) 'TOP词组所在的RANGE位置
BkName = "B" & VBA.Format(TopCount, "000") '定义一个书签名
HyBkName = "A" & VBA.Format(TopCount, "000") '定义一个超级链接的名称(位置)
'添加一个书签
ActiveDocument.Bookmarks.Add Name:=BkName, Range:=TopRange
'添加一个超级链接
ActiveDocument.Hyperlinks.Add Anchor:=TopRange, Address:="", SubAddress:=HyBkName
Loop
End With
Set myCol = myTable.Columns(5) '定义一个列对象
For Each oCell In myCol.Cells
RowId = oCell.RowIndex '取得行号
If RowId > 1 Then '不为首行
Set cellRange = oCell.Range.Paragraphs(1).Range '定义一个RANGE对象为该单元格的第一个段落
HyBkName = "B" & VBA.Format(RowId - 1, "000")
'添加一个超级链接
ActiveDocument.Hyperlinks.Add Anchor:=cellRange, Address:="", SubAddress:=HyBkName
End If
Next
End With
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''
'辅助小代码,删除所有书签
Sub DelAllBK()
Dim i As Bookmark
For Each i In ActiveDocument.Bookmarks
i.Delete
Next
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2005-12-4 07:29 | 显示全部楼层
一觉醒来,发现守柔老师不但帮我把程序写好了,而且每行都加了注释,方便了我这个初学者阅读程序,真是太感谢守柔老师了。同时也非常感谢热心的gues1688。

TA的精华主题

TA的得分主题

 楼主| 发表于 2005-12-4 08:01 | 显示全部楼层

我运行了一下守柔老师的代码,还有一个小问题,问题好像在这部分:

Set cellRange = oCell.Range.Paragraphs(1).Range '定义一个RANGE对象为该单元格的第一个段落
HyBkName = "B" & VBA.Format(RowId - 1, "000")
'添加一个超级链接
ActiveDocument.Hyperlinks.Add Anchor:=cellRange, Address:="", SubAddress:=HyBkName

单元格中如果有两个段落的话,是没问题的;但是如果只有一个段落,那么超链接就会加在前面,就像这样:B089上海通用每年各品牌都有新车

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-16 03:16 , Processed in 0.048079 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表