2 yutianbian yutianbian 于 2014.12.18 22:15 提问

请哪位大神知道如何用VBA代码做word索引,求代码啊。。拜托拜托。。

请哪位大神知道如何用VBA(visual basic)代码做word索引,求代码啊。。拜托拜托。。

7个回答

Topc008
Topc008   Rxr 2014.12.19 08:25
已采纳

我也来个:需要你手动提供关键词哦....

Sub Test()
BiaoJiAll "编辑|学校" ''
End Sub
Sub BiaoJiAll(ByVal bStr As String)
''bStr为关键词,用|分割
On Error Resume Next
Dim i As Long, w1 As String, ww
ww = Split(bStr, "|")
If UBound(ww) >= 0 Then
For i = 0 To UBound(ww)
Selection.HomeKey Unit:=wdStory ''移动到开始
With Selection.Find
.ClearFormatting
.Text = ww(i)
.Execute
If .Found Then ''如果找到了则添加到索引
ActiveDocument.Indexes.MarkAllEntries Range:=Selection.Range, Entry:= _
ww(i), EntryAutoText:=ww(i), CrossReference:="", CrossReferenceAutoText _
:="", BookmarkName:="", Bold:=False, Italic:=False
End If
End With
Next
''定位到最后
Selection.EndKey Unit:=wdStory
''在文档最后插入索引
ThisDocument.Indexes.Add Range:=Selection.Range, HeadingSeparator:= _
wdHeadingSeparatorNone, Type:=wdIndexIndent, RightAlignPageNumbers:= _
True, NumberOfColumns:=2, SortBy:=wdIndexSortByStroke, IndexLanguage _
:=wdSimplifiedChinese
End If
End Sub

Topc008
Topc008 回复yutianbian: 不会吧,你新开一个word,随便输入一点内容,但要包含 学校、编辑等关键词,然后复制代码到document的vba里,执行test应该马上就能看到结果的。
大约 3 年之前 回复
yutianbian
yutianbian 而且运行之后,鼠标会跳到最后一行,可是却没有索引的建立
大约 3 年之前 回复
yutianbian
yutianbian 我是初学,还请帮帮忙啊。。
大约 3 年之前 回复
yutianbian
yutianbian 你好,这个编译出现错误,显示 缺少 end sub 请问你知道如何更改么?
大约 3 年之前 回复
devmiao
devmiao   Ds   Rxr 2014.12.18 23:11
 Dim colWords as Collection
Set colWords = New Colection
'add words you don't want to index
colWords.Add "and"
colWords.Add "you"

Dim wrd As Range
For Each wrd In ActiveDocument.Words

  'only if we have 3 chars we index
  If Len(Trim(wrd.Text)) > 2 Then

     ' prevent the field from being Indexed as well...
     Dim infield As Boolean
     infield = False
     Dim fld As Field
     For Each fld In ActiveDocument.Fields
       If (wrd.Start >= fld.Code.Start And wrd.End <= fld.Code.End) Then
         infield = True
         Exit For 'break out
       End If
     Next

     If (Not infield) Then
        ' check if we already indexed? 
        Dim findWord as String
        findWord = LCASE(wrd.Text)
        For Each cached in colWords
            if cached = findWord Then
               infield = True
               Exit For 'break out
            end If 
        Next
        If  (Not infield) Then 
           ActiveDocument.Indexes.MarkAllEntries Range:=wrd, Entry:=wrd.Text, _
             EntryAutoText:=wrd.Text, CrossReference:="", CrossReferenceAutoText:="", _
             BookmarkName:="", Bold:=False, Italic:=False

           colWords.Add findWord

         End If
     End If
   End If
Next
yutianbian
yutianbian 你好,这个显示编译错误 显示 用户定义类型未定义,能不能帮忙看看问题出在哪里。。你可以运行的出来是么?
大约 3 年之前 回复
devmiao
devmiao   Ds   Rxr 2014.12.18 23:15

总有一款适合你

Sub CreateIndex()
 '
 ' CreateIndex Macro
 With ActiveDocument.PageSetup
 .LineNumbering.Active = False
 .Orientation = wdOrientPortrait
 .TopMargin = InchesToPoints(0.8)
 .BottomMargin = InchesToPoints(0.8)
 .LeftMargin = InchesToPoints(0.8)
 .RightMargin = InchesToPoints(0.8)
 .Gutter = InchesToPoints(0)
 .HeaderDistance = InchesToPoints(0.5)
 .FooterDistance = InchesToPoints(0.5)
 .PageWidth = InchesToPoints(8.5)
 .PageHeight = InchesToPoints(11)
 .FirstPageTray = wdPrinterDefaultBin
 .OtherPagesTray = wdPrinterDefaultBin
 .SectionStart = wdSectionNewPage
 .OddAndEvenPagesHeaderFooter = False
 .DifferentFirstPageHeaderFooter = False
 .VerticalAlignment = wdAlignVerticalTop
 .SuppressEndnotes = False
 .MirrorMargins = False
 .TwoPagesOnOne = False
 .GutterPos = wdGutterPosLeft
 End With

 Selection.Sections(1).Headers(1).pageNumbers.Add
 PageNumberAlignment:= _
 wdAlignPageNumberRight, FirstPage:=True

 Dim quote As String
 Dim Keyword As String
 Dim j As Integer
 quote = """"
 Dim found_key As Boolean
 Dim startSearch As Long
 Dim endSearch As Long

 Close #1
 Open "c:\boss_info_index.txt" For Input As #1

 Set myRange = ActiveDocument.Content

 j = 0
 Do While Not EOF(1) ' Loop until end of file.
 Set myRange = ActiveDocument.Content
 endSearch = myRange.End

 Input #1, Keyword

 j = 0

 With myRange.Find
 .Text = Keyword
 .Forward = True
 .MatchWholeWord = True
 .MatchCase = False
 End With

 While myRange.Find.Execute
 myRange.Collapse wdCollapseEnd
 Set myIndexEntry = myRange.Fields.Add(myRange,
 Type:=wdFieldIndexEntry, _
 Text:=quote & Keyword & quote)


 startSearch = myRange.End
 startSearch = startSearch + 7
 Set myRange = ActiveDocument.Content
 myRange.Start = startSearch

 If startSearch endSearch - 1 Then
 GoTo skip_while
 End If

 With myRange.Find
 .Text = Keyword
 .Forward = True
 .MatchWholeWord = True
 .MatchCase = False
 End With

 ' this code is because I had a loop here
 j = j + 1
 If j 300 Then
 myRange.Bold = True
 Exit Do
 End If

 Wend

 skip_while:

 Loop

 Close #1 ' Close file.

 myRange.Start = 0
 myRange.End = 0
 With ActiveDocument
 .Indexes.Add Range:=myRange, HeadingSeparator:= _
 wdHeadingSeparatorNone, Type:=wdIndexIndent,
 RightAlignPageNumbers:= _
 True, NumberOfColumns:=1, IndexLanguage:=wdEnglishUS
 .Indexes(1).TabLeader = wdTabLeaderDots
 End With


 End Sub


yutianbian
yutianbian 你好,我是初学者,你给我的代码我都运行不了,显示有错误,我不清楚是怎么回事儿,能不能麻烦你再帮忙看一下。。
大约 3 年之前 回复
yutianbian
yutianbian PageNumberAlignment:=_wdAlignPageNumberRight, FirstPage:=True 显示错误啊
大约 3 年之前 回复
devmiao
devmiao   Ds   Rxr 2014.12.18 23:14
Sub DemoIndex()
 Dim Tbl As Table
 Dim r As Range
 With ActiveDocument
 ' for each table
 For Each Tbl In .Tables
 ' set range for paragraph before the table
 Set r = Tbl.Range.Characters.First.Previous.Paragraphs.First.Range
 ' use text that pparagraph for Index entry
 .Indexes.MarkEntry Range:=r, _
 Entry:=r.Text, _
 EntryAutoText:=r.Text, _
 CrossReference:="", CrossReferenceAutoText:="", _
 BookmarkName:="", Bold:=False, Italic:=False, Reading:=""
 Set r = Nothing
 ' go to next table
 Next
 ' go to end of document and make a new section
 ' put in text for a title/heading
 With Selection
 .EndKey Unit:=wdStory
 .InsertBreak Type:=wdSectionBreakNextPage
 .TypeText "Table List" & vbCrLf & vbCrLf
 End With
 ' create Index listing
 .Indexes.Add Range:=Selection.Range, HeadingSeparator:= _
 wdHeadingSeparatorNone, Type:=wdIndexIndent, RightAlignPageNumbers:= _
 False, NumberOfColumns:=2, IndexLanguage:=wdEnglishCanadian
 .Indexes(1).TabLeader = wdTabLeaderDots
 End With
 End Sub

lzp_lrp
lzp_lrp   Ds   Rxr 2014.12.19 08:54

最简单的方法,录制宏,然后手工操作,然后查看宏就可以了

save4me
save4me   Ds   Rxr 2014.12.18 22:57
save4me
save4me 额?怎么我引用的链接变成这个问题的链接了?谢谢柔软的胖纸,你下面的这个链接才是我引用的
大约 3 年之前 回复
hjkNet
hjkNet http://www.4byte.cn/question/586405/index-of-all-words-used-in-ms-word-document.html这个? 超链好像有点问题
大约 3 年之前 回复
Topc008
Topc008   Rxr 2014.12.26 14:13

我是word2003的,这代码在我那很正常啊,没有出现错误,如果不能建立索引,是不是你输入的内容中根本就没有关键词啊。

测试方法:新开一个word,随便输入一些内容,但必须包含学校、编辑2个关键词,然后复制下面的代码到当前document的vba里,
运行test会立即看到效果的。


Sub Test()
    BiaoJiAll "编辑|学校" ''
End Sub
Sub BiaoJiAll(ByVal bStr As String)
    ''bStr为关键词,用|分割
    On Error Resume Next
    Dim i As Long, w1 As String, ww
    ww = Split(bStr, "|")
    If UBound(ww) >= 0 Then
        For i = 0 To UBound(ww)
            Selection.HomeKey Unit:=wdStory ''移动到开始
            With Selection.Find
                .ClearFormatting
                .Text = ww(i)
                .Execute
                If .Found Then ''如果找到了则添加到索引
                    ActiveDocument.Indexes.MarkAllEntries Range:=Selection.Range, Entry:= _
                    ww(i), EntryAutoText:=ww(i), CrossReference:="", CrossReferenceAutoText _
                    :="", BookmarkName:="", Bold:=False, Italic:=False
                End If
            End With
        Next
        ''定位到最后
        Selection.EndKey Unit:=wdStory
        ''在文档最后插入索引
        ThisDocument.Indexes.Add Range:=Selection.Range, HeadingSeparator:= _
        wdHeadingSeparatorNone, Type:=wdIndexIndent, RightAlignPageNumbers:= _
        True, NumberOfColumns:=2, SortBy:=wdIndexSortByStroke, IndexLanguage _
        :=wdSimplifiedChinese
    End If
End Sub

Csdn user default icon
上传中...
上传图片
插入图片
准确详细的回答,更有利于被提问者采纳,从而获得C币。复制、灌水、广告等回答会被删除,是时候展现真正的技术了!