yutianbian
脱线布偶
2014-12-18 14:15
采纳率: 46.2%
浏览 2.4k
已采纳

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

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

  • 点赞
  • 写回答
  • 关注问题
  • 收藏
  • 邀请回答

7条回答 默认 最新

  • Topc008
    一如既往哈 2014-12-19 00: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

    点赞 评论
  • save4me
    save4me 2014-12-18 14:57
    点赞 评论
  • devmiao
    devmiao 2014-12-18 15: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
    
    点赞 评论
  • devmiao
    devmiao 2014-12-18 15: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
    
    
    点赞 评论
  • devmiao
    devmiao 2014-12-18 15: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
    
    
    
    点赞 评论
  • lzp_lrp
    WorldMobile 2014-12-19 00:54

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

    点赞 评论
  • Topc008
    一如既往哈 2014-12-26 06: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
    
    
    点赞 评论

相关推荐