[求助]查找问题，请版主帮忙看看

duke008 · 发表于 2006-4-26 11:57

Sub inserthl() Dim i As Integer, j As Integer, bknameB As String, bknameA As String ActiveDocument.Fields.Unlink j = 0 For i = 2 To ActiveDocument.Tables.Count If InStr(ActiveDocument.Tables(i).Cell(1, 1).Range, "媒体名称:") <> 0 Then j = j + 1 bknameB = "B" & VBA.Format(j, "000") ActiveDocument.Bookmarks.Add Name:=bknameB, Range:=ActiveDocument.Range(ActiveDocument.Tables(i).Cell(4, 2).Range.start, ActiveDocument.Tables(i).Cell(4, 2).Range.start) End If Next i j = 0 With ActiveDocument.Tables(1) For i = 2 To .Rows.Count j = j + 1 bknameA = "A" & VBA.Format(j, "000") bknameB = "B" & VBA.Format(j, "000") ActiveDocument.Bookmarks.Add Name:=bknameA, Range:=ActiveDocument.Range(.Cell(i, 6).Range.start, .Cell(i, 6).Range.start) ActiveDocument.Hyperlinks.Add Anchor:=ActiveDocument.Range(.Cell(i, 6).Range.start, .Cell(i, 6).Range.End - 1), address:="", SubAddress:=bknameB Next i End With '以下部分出现问题： j = 0 Set MyRange = ActiveDocument.Content '定义一个RANGE对象,为主文档文字部分 With MyRange.Find '查找 .ClearFormatting .Font.Name = "黑体" .Format = True .Text = "返回" Do While .Execute j = j + 1 '计数 Set ReturnRange = MyRange.Words(1) bknameA = "A" & VBA.Format(j, "000") '定义一个书签名 '添加一个超级链接 ActiveDocument.Hyperlinks.Add Anchor:=ReturnRange, address:="", SubAddress:=bknameA Loop End With End Sub 以上程序的最后一部分用于查找文档中字体为黑体的“返回”，加超链接。问题如下：在运行程序时，总是重复对文档中第一个黑体的“返回”进行操作，而不往下查找，而且循环不停。请守柔版主或孔兄或其他路过的大侠帮忙看看问题出在哪里，谢谢！

konggs · 发表于 2006-4-26 12:25

range对象，在查询时，总是第一个造中，所以加两句改变range对象的范围。

duke008 · 发表于 2006-4-26 13:58

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

这是很久以前老大帮我写的程序，我是照这个改的呀，查找部分基本没改啊，不知道哪里出的问题。

konggs · 发表于 2006-4-26 18:55

老大写的？闪，不然要出丑了。[em04]

守柔 · 发表于 2006-4-27 06:57

时间太忙，KONGGS又不愿意出手，只好草草地修改了一下，供参考了：

Sub Inserthyperlink()
Dim i As Integer, j As Integer, bknameB As String, bknameA As String
Dim myRange As Range, myTable As Table
Application.ScreenUpdating = False
With ActiveDocument
.Fields.Unlink
j = 0
For i = 2 To .Tables.Count
Set myTable = .Tables(i)
If InStr(myTable.Cell(1, 1).Range, "媒体名称:") <> 0 Then
j = j + 1
bknameB = "B" & VBA.Format(j, "000")
.Bookmarks.Add Name:=bknameB, Range:=.Range(myTable.Cell(4, 2).Range.Start, myTable.Cell(4, 2).Range.Start)
End If
Next i

j = 0
Set myTable = .Tables(1)
For i = 2 To myTable.Rows.Count
j = j + 1
bknameA = "A" & VBA.Format(j, "000")
bknameB = "B" & VBA.Format(j, "000")
Set myRange = .Range(myTable.Cell(i, 6).Range.Start, myTable.Cell(i, 6).Range.End - 1)
.Bookmarks.Add Name:=bknameA, Range:=myRange
.Hyperlinks.Add Anchor:=myRange, Address:="", SubAddress:=bknameB
Next i

j = 0
Set myRange = .Content '定义一个RANGE对象,为主文档文字部分
NextFind: With myRange.Find '查找
.ClearFormatting
.Font.Name = "黑体"
.Format = True
.Text = "返回"
Do While .Execute
j = j + 1 '计数
bknameA = "A" & VBA.Format(j, "000") '定义一个书签名
'添加一个超级链接
ActiveDocument.Hyperlinks.Add Anchor:=myRange, Address:="", SubAddress:=bknameA
myRange.SetRange myRange.Paragraphs(1).Range.End, ActiveDocument.Content.End
GoTo NextFind
Loop
End With
End With
Application.ScreenUpdating = True
End Sub

konggs · 发表于 2006-4-27 08:04

不是啊，我是写了一个写你类似的，但在我的机子通不过。

呵呵，但简单的能通过。

又一看，原来是你写的，所以。我就心荒了。

duke008 · 发表于 2006-4-27 09:55

首先感谢守柔版主和孔兄的热心帮助。不过在看到老大的程序之前，我是这样解决的：

将最后一部分改为：

j = 0
ActiveDocument.Range.Select
With Selection.Find '查找
.ClearFormatting
.Font.Name = "黑体"
.Format = True
.Text = "返回"
Do While .Execute
j = j + 1 '计数
Set ReturnRange = Selection.Range.Words(1)
bknameA = "A" & VBA.Format(j, "000") '定义一个书签名
'添加一个超级链接
ActiveDocument.Hyperlinks.Add Anchor:=ReturnRange, address:="", SubAddress:=bknameA

Loop
End With

但是我很奇怪，很久以前老大帮我写的那个程序运行的很好，而我这次对其在查找部分的程序几乎没有改动，都是先用

“ Set MyRange = ActiveDocument.Content ” 定义一个RANGE对象,为主文档文字部分

再在MyRange中查找
With MyRange.Find

为什么运行结果就不同呢？

konggs · 发表于 2006-4-27 10:36

duke008兄，主要是这个：

（上次老大叫我认真看的）

说明

在 Selection 对象中使用 Find 对象时，找到符合选择条件的文本后选定内容将会改变。下例选定下一次出现的“blue”。

Selection.Find.Execute FindText:="blue", Forward:=True

在 Selection 对象中使用 Range 对象时，找到符合选择条件的文本后选定内容不会改变，但 Range 对象将会重新定义。下列示例在活动文档中查找出现的第一个“blue”。如果在文档中找到“blue”，myRange 将重新定义，并且“blue”的字体变为粗体。

好好想想，就知道为什么了。

duke008 · 发表于 2006-4-27 13:57

孔兄啊，你好像有些东西没贴上来啊。

konggs · 发表于 2006-4-27 17:01

在VBE中，输入FIND，造中，按F1就看到更多的了。

		自动登录	找回密码
密码			免费注册