宏不响应大文本。请帮助我 [英] macro NOT responding for large text.please help me

问题描述

选项显式

Dim strFnd As String



Sub HilightDocumentDuplicates（）

'关闭屏幕更新

Application.ScreenUpdating = False

Dim strFolder As String，strFile As String，wdDoc As Document

Dim StrTmp As String，i As Long， TrkStatus 作为Boolean，bFnd As Boolean

'提示要处理的文件夹

strFolder = GetFolder

如果strFolder =""然后退出Sub¥
strFile = Dir（strFolder&" \ * .doc"，vbNormal）

'处理文件夹中的每个文件

虽然strFile<> ""

 设置wdDoc = Documents.Open（FileName：= strFolder&" \"& strFile，_

               AddtorecentFiles：= False，Visible：= False）

  '存储当前曲目更改状态，然后关闭

  TrkStatus = wdDoc.TrackRevisions

  wdDoc.TrackRevisions = False

  '编译查找符号

 致电ConcordanceBuilder（wdDoc）

  '处理一致性中的所有单词

 对于i = 1到UBound（拆分（strFnd，"""））

    StrTmp =拆分（strFnd，""）（i）

    bFnd = False

   使用wdDoc.Range

      With .Find

        .ClearFormatting

        '只查找重复的单词

        .Text = StrTmp

        .Replacement.Text =""

        .Forward = True

        .Wrap = wdFindStop

        .Format = False

        .MatchCase = False

        .MatchWholeWord = True

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

        。执行

     结束与$
      Do While .Find.Found

       如果bFnd = True则为
          .Duplicate.HighlightColorIndex = wdBrightGreen

       结束如果

        bFnd = True

        .Collapse wdCollapseEnd

        .Find.Execute

     循环

   结束与$
 下一个

  '恢复原始跟踪更改状态

  wdDoc.TrackRevisions = TrkStatus

  wdDoc.Close SaveChanges：= True

  strFile = Dir（）

Wend

Set wdDoc = Nothing

'恢复屏幕更新

Application.ScreenUpdating =真实
结束子

$
函数GetFolder（）字符串

Dim oFolder As Object

GetFolder =""

设置oFolder = CreateObject（" Shell.Application"）。BrowseForFolder（0，" Choose a folder"，0）

如果（不是oFolder什么都没有）那么GetFolder = oFolder.Items.Item.Path

设置oFolder = Nothing

结束函数



Sub ConcordanceBuilder（wdDoc As Document）

Dim StrIn As String，StrTmp As String，StrIncl As String，StrExcl As String

Dim i As Long， j As Long，k As Long

'定义exlusions列表

StrExcl =" a，am，and，as，as，at，b，be，but，通过，C，能，厘米，d，做到了，这样做，确实，E，例如，EN，当量等，F，为，" &安培; _
$
          " G，得到，去，得了，H，有，有，他，她，他，怎么样，我，即，如果在，成，就是它，它，J，K，L，M，" &安培; _
$
          "我，MI，MM，我，正NB，不，不，O的，呐，关闭，好，上一个，或者我们的，出，P，Q，R，RE，S，她，所以，" &安培; _
$
          " t为，他们，他们，他们，T，于U，V，W，是我们，是，谁，会的，会的，X，Y，YD，你，你，Z"

'为初始清理无法生存的条款定义一个包含列表

StrIncl =" c / c ++，c＃"

with wdDoc

  '获取文档的文字

  StrIn = .Content.Text

  '删除不需要的字符

 对于i = 1到255

   选择案例i $
     案例1至38,40至44,46至64,91至96,123至144,147至149,152至171,174至191,247至
     &NBSP; StrIn =替换（StrIn，Chr（i），""）

   结束选择

 下一个

  '将智能单引号转换为普通单引号&删除单词开头/结尾处的任何内容

  StrIn =替换（替换（替换（替换（替换（StrIn，Chr（145），"'"），Chr（146），"'"），"'"，"""，" '"，""）

  '转换为小写字母

  StrIn =" " &安培; LCase（Trim（StrIn））& " "

  '处理排除清单

 对于i = 0到UBound（分割（StrExcl，"，"）））
    InStr（StrIn，"& Split（StrExcl，"，"）（i）&""）> 0

      StrIn =替换（StrIn，"& Split（StrExcl，"，"）（i）&""，""）

     ; Wend b
 下一个

  '恢复指定的内含物

  StrIn =替换（StrIncl，"，"，""）& StrIn

  '清理任何重复的空格

  InStr（StrIn，" "）> 0

    StrIn =替换（StrIn，" "，""）

  Wend b
  StrIn =" " &安培;修剪（StrIn）& " "

  j = UBound（拆分（StrIn，"""））

 对于i = 1到j

    StrTmp =拆分（StrIn，""）（1）

    '查找文档中每个单词的出现次数

   而InStr（StrIn，"& StrTmp&"""）> 0

      StrIn =替换（StrIn，"& StrTmp&""""）

    Wend b
    k = j - UBound（拆分（StrIn，""）））
    '如果出现多次，请将该字词添加到我们的查找列表中。
   如果k> 1然后

      strFnd = strFnd& " " &安培; StrTmp

   结束如果是
    j = UBound（拆分（StrIn，"""））

 下一个

结束与
结束子

Option Explicit
Dim strFnd As String

Sub HilightDocumentDuplicates()
' Turn Off Screen Updating
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim StrTmp As String, i As Long, TrkStatus  As Boolean, bFnd As Boolean
'Prompt for the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Process each file in the folder
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
              AddtorecentFiles:=False, Visible:=False)
  ' Store current Track Changes status, then switch off
  TrkStatus = wdDoc.TrackRevisions
  wdDoc.TrackRevisions = False
  'Compile the Find concordance
  Call ConcordanceBuilder(wdDoc)
  'Process all words in the concordance
  For i = 1 To UBound(Split(strFnd, " "))
    StrTmp = Split(strFnd, " ")(i)
    bFnd = False
    With wdDoc.Range
      With .Find
        .ClearFormatting
        'Look for duplicated words only
        .Text = StrTmp
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
      End With
      Do While .Find.Found
        If bFnd = True Then
          .Duplicate.HighlightColorIndex = wdBrightGreen
        End If
        bFnd = True
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
  Next
  ' Restore original Track Changes status
  wdDoc.TrackRevisions = TrkStatus
  wdDoc.Close SaveChanges:=True
  strFile = Dir()
Wend
Set wdDoc = Nothing
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Sub ConcordanceBuilder(wdDoc As Document)
Dim StrIn As String, StrTmp As String, StrIncl As String, StrExcl As String
Dim i As Long, j As Long, k As Long
'Define the exlusions list
StrExcl = "a,am,and,are,as,at,b,be,but,by,c,can,cm,d,did,do,does,e,eg,en,eq,etc,f,for," & _
          "g,get,go,got,h,has,have,he,her,him,how,i,ie,if,in,into,is,it,its,j,k,l,m," & _
          "me,mi,mm,my,n,na,nb,no,not,o,of,off,ok,on,one,or,our,out,p,q,r,re,s,she,so," & _
          "t,the,their,them,they,t,to,u,v,w,was,we,were,who,will,would,x,y,yd,you,your,z"
'Define an inclusions list for terms that otherwise don't survive the initial cleanup
StrIncl = "c/c++,c#"
With wdDoc
  'Get the document's text
  StrIn = .Content.Text
  'Strip out unwanted characters
  For i = 1 To 255
    Select Case i
      Case 1 To 38, 40 To 44, 46 To 64, 91 To 96, 123 To 144, 147 To 149, 152 To 171, 174 To 191, 247
      StrIn = Replace(StrIn, Chr(i), " ")
    End Select
  Next
  'Convert smart single quotes to plain single quotes & delete any at the start/end of a word
  StrIn = Replace(Replace(Replace(Replace(StrIn, Chr(145), "'"), Chr(146), "'"), "' ", " "), " '", " ")
  'Convert to lowercase
  StrIn = " " & LCase(Trim(StrIn)) & " "
  'Process the exclusions list
  For i = 0 To UBound(Split(StrExcl, ","))
    While InStr(StrIn, " " & Split(StrExcl, ",")(i) & " ") > 0
      StrIn = Replace(StrIn, " " & Split(StrExcl, ",")(i) & " ", " ")
    Wend
  Next
  'Restore the specified inclusions
  StrIn = Replace(StrIncl, ",", " ") & StrIn
  'Clean up any duplicate spaces
  While InStr(StrIn, "  ") > 0
    StrIn = Replace(StrIn, "  ", " ")
  Wend
  StrIn = " " & Trim(StrIn) & " "
  j = UBound(Split(StrIn, " "))
  For i = 1 To j
    StrTmp = Split(StrIn, " ")(1)
    'Find how many occurences of each word there are in the document
    While InStr(StrIn, " " & StrTmp & " ") > 0
      StrIn = Replace(StrIn, " " & StrTmp & " ", " ")
    Wend
    k = j - UBound(Split(StrIn, " "))
    'If there's more than one occurence, add the word to our Find list
    If k > 1 Then
      strFnd = strFnd & " " & StrTmp
    End If
    j = UBound(Split(StrIn, " "))
  Next
End With
End Sub

推荐答案

此代码失败的位置？你是否在调试模式下使用测试文件运行它？

Where is this code failing? Have you run it in debug mode with a test file?

这就是我的建议。

这篇关于宏不响应大文本。请帮助我的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！