excel vba 运行太慢了，怎么做小修改让代码运行快一些

Posted 2023-04-13

下面代码运行起来速度实在太慢，高手看看哪里可以改进下啊 ，谢谢了！

Private Sub CommandButton1_Click()
Dim xlApp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet
Set xlApp = New Excel.Application
Set xlbook = xlApp.Workbooks.Open("D:\EXCEL\ITS电气元器件库.xlsm")
xlApp.Visible = False
Set xlsheet = xlbook.Worksheets("Sheet1")
Dim i As Integer, j As Integer, h As Integer, k As Integer, l As Integer, m As Integer, n As Integer, o As Integer
n = xlApp.WorksheetFunction.CountA(xlApp.Sheets("Sheet1").range("d:d"))
m = WorksheetFunction.CountA(range("d:d"))
range("j3:s350").ClearContents
range("j3:s350").Interior.ColorIndex = 2
Cells(1, 10) = m
Cells(1, 11) = n
j = 3
Do Until j > m
For i = 3 To n
If (InStr(1, Cells(j, 4), xlsheet.Cells(i, 4), vbTextCompare) > 0 Or InStr(1, Cells(j, 7), xlsheet.Cells(i, 4), vbTextCompare) > 0) And Not Cells(j, 4) = "" And Not xlsheet.Cells(i, 4) = "" Then
Cells(j, "J") = xlsheet.Cells(i, "B")
Cells(j, "K") = xlsheet.Cells(i, "E")
Cells(j, "L") = xlsheet.Cells(i, "F")
Cells(j, "M") = xlsheet.Cells(i, "G")
Cells(j, "N") = xlsheet.Cells(i, "H")
Cells(j, "O") = xlsheet.Cells(i, "I")
Cells(j, "P") = xlsheet.Cells(i, "J")
Cells(j, "Q") = xlsheet.Cells(i, "K")
Cells(j, "R") = xlsheet.Cells(i, "L")
Cells(j, "S") = xlsheet.Cells(i, "M")
Cells(j, "T") = xlsheet.Cells(i, "N")
If xlsheet.Cells(i, 3) = Cells(j, 5) Then
range("j" & j & ":s" & j).Interior.ColorIndex = 4
Else
range("j" & j & ":s" & j).Interior.ColorIndex = 3
End If
Exit For
Else
End If
Next i
j = j + 1
Loop
With xlbook
.Close
End With
Set xlsheet = Nothing
Set xlbook = Nothing
Set xlApp = Nothing
End Sub

如果代码能正确运行，可禁用屏幕刷新提高速度，如果工作表中还有大量与“J~T”列相关的公式，可停止自动重算提高速度。以上方法不行，就只能大动代码才能提高速度。一是改用数组，二是取消开始的几个对象，改在本文件所在 Application 里处理"D:\EXCEL\ITS电气元器件库.xlsm"这个文件追问

怎么样才能改在本文件所在 Application 里处理"D:\EXCEL\ITS电气元器件库.xlsm"这个文件，而不是另外新建一个呢，谢谢了！

追答

Set xlbook = Workbooks.Open("D:\EXCEL\ITS电气元器件库.xlsm")

以上就能在本EXCEL程序打开这个文件，关闭时：xlbook.close
其他相关代码要修改。

参考技术A 这段代码之所以执行的慢，是因为频繁地读写工作表对象追问

怎么样才能让它不这么频繁读写工作表呢

Excel VBA操作word文件

功能：批量添加，解除word打开密码。
如何修改才能让这两段代码，在excel中能够运行？
Sub SAMPLE()
'批量添加打开文档密码
Dim myDialog As FileDialog, oFile As Variant, oDoc As Document
On Error Resume Next
'定义一个文件夹选取对话框
Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
With myDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择
If .Show <> -1 Then Exit Sub
For Each oFile In .SelectedItems '在所有选取项目中循环
Set oDoc = Documents.Open(FileName:=oFile, Visible:=False)
With oDoc
.Password = "你的密码"
.Close True '关闭文档
End With
Next oFile
End With
End Sub

Sub Example()
'批量解除打开文档密码
Dim myDialog As FileDialog, oFile As Variant, oDoc As Document
Dim myPassWord As String
' On Error Resume Next
myPassWord = "tangqingfu"
'定义一个文件夹选取对话框
Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
With myDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 WORD 文件", "*.doc", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择
If .Show <> -1 Then Exit Sub
For Each oFile In .SelectedItems '在所有选取项目中循环
Set oDoc = Documents.Open(FileName:=oFile, Visible:=False, PasswordDocument:=myPassWord)
With oDoc
.ReadOnlyRecommended = False '请勿省略
.Password = ""
.Save
.Close '关闭文档
End With
Next oFile
End With
End Sub

在 Word 中，几乎所有的操作都要调用 Document 对象本身或其内容。当您用 VBA 操作 Word 时，Document 对象表示一个打开的文档，而且所有的 Document 对象都是 Application 对象的 Documents 集合的成员。
文档是一个由字符、单词、句子和段落组成的集合，字符组成单词，单词组成句子，句子组成段落，等等。因此，每一个 Document 对象都具有 Characters、Words、Sentences 和 Paragraghs 四个集合。此外，每个文档具有一个包含一个或多个节的 Sections 集合，每一个节都有一个包含该节页眉和页脚的 HeadersFooters 集合。
注意： 您可以在 Microsoft Office 2000 开发人员对象模型指南（英文）中查阅完整的 Word 对象模型。另外，您也可以使用对象浏览器和 Microsoft Word Visual Basic 参考帮助来学习有关具体某个对象、属性、方法和事件的详细内容。
通过 VBA 使用 Word 时，Document 对象处于中心位置。如果您要打开文档或创建新文档，就要创建新的 Document 对象。每个打开或新创建的文档均被添加至 Documents 集合。具有焦点的文档称为活动文档，由 ActiveDocument 属性表示。
Document 对象作为 Documents 集合中的一个成员，您可以通过使用 Document 对象的索引值（Document 对象在 Documents 集合中的位置，1 是集合中的第一个文档）或名称来引用它。另外，您也可以使用 ActiveDocument 属性来引用当前具有焦点的文档。例如，如果名为 Policies.doc 的文档是唯一打开的文档，则以下三个对象变量将全部指向 Policies.doc：
Dim docOne As Word.Document
Dim docTwo As Word.Document
Dim docThree As Word.Document
Set docOne = Documents(1)
Set docTwo = Documents("Policies.doc")
Set docThree = ActiveDocument
一般情况下不要使用 Documents 集合中的索引值来引用文档，因为当其它文档打开或关闭时，某个特定文档的索引值可能会随之改变。通常，您可以通过使用 ActiveDocument 属性或使用 Documents 集合的 Add 方法或 Open 方法创建的 Document 对象变量。以下示例显示了如何使用 ActiveDocument 属性把一个地址添加到当前具有焦点的文档中：
With ActiveDocument
.Envelope.Insert Address:="Office Talk" _
& vbCrLf & "One Microsoft Way" & vbCrLf _
& "Redmond, WA 98052", ReturnAddress:= _
"David Shank" & vbCrLf & _
"77 First Street" & vbCrLf & _
"Any Town, USA 12345"
End With
下面的示例说明如何通过使用 Documents 集合的 Open 方法，实例化 Document 对象变量。
Dim docPolicy As Word.Document
Set docPolicy = Documents.Open("c:\my documents\policies.doc")
最后一个示例显示如何通过使用 Add 方法，为新的空文档创建 Document 对象的实例。
Dim docPolicy As Word.Document
Set docPolicy = Documents.Add
通过使用 Open 方法打开的文档，或者通过使用 Add 方法创建的文档，都将成为用 ActiveDocument 属性表示的当前活动文档。如果您想使 Documents 集合里的其它文档成为活动文档，可使用 Document 对象的 Active 方法。
一旦您获取了要操作的 Document 对象，绝大部分您想通过 VBA 进行的工作将涉及文本的操作。首先要指定文档的一个部分，然后对它进行某些操作。例如，添加或删除文本，或者设置单词或字符的格式。您可以使用 Range 或 Selection 这两个对象来完成很多工作。
Word vba常用语句100句
1、系统参数
(01) Application.ActivePrinter ‘获取当前打印机
(02) Application.Height '当前应用程序文档的高度
(03) Application.Width ‘当前应用程序文档的宽度
(04) Application.Build ‘获取Word版本号和编译序号
(05) Application.Caption ‘当前应用程序名
(06) Application.DefaultSaveFormat '返回空字符串，表示Word文档
(07) Application.DisplayRecentFiles '返回是否显示最近使用的文档的状态
(08) Application.Documents.Count '返回当前打开的文档数
(09) Application.FontNames.Count ‘返回当前可用的字体数
(10) Application.Left ‘返回当前文档的水平位置
(11) Application.MacroContainer.FullName '返回当前文档名，包括所在路径
Application.MacroContainer.pach '返回当前文档路径
Application.ActiveDocument.Path ‘获得文件的相对路径
(12) Application.NormalTemplate.FullName '返回文档标准模板名称及所在位置
(13) Application.RecentFiles.Count '返回最近打开的文档数目
(14) Application.System.CountryRegion '返回应用程序所在的地区代码
(15) Application.System.FreeDiskSpace ‘返回应用程序所在磁盘可用空间
(16) Application.System.HorizontalResolution '返回显示器的水平分辨率
(17) Application.System.VerticalResolution '返回显示器的垂直分辨率
(18) Application.System.LanguageDesignation '返回系统所使用的语言
(19) Application.System.MathCoprocessorInstalled ‘返回系统是否安装了数学协处理器
(20) Application.System.OperatingSystem ‘返回当前操作系统名
(21) Application.System.ProcessorType '返回计算机处理器名
(22) Application.System.Version ‘返回操作系统的版本号
(23) Application.Templates.Count '返回应用程序所使用的模板数
(24) Application.UserName '返回应用程序用户名
(25) Application.Version ‘返回应用程序的版本号

2、Documents/Document对象
(26) ActiveDocument.AttachedTemplate.FullName '返回当前文档采用的模板名及模板所在位置
(27) ActiveDocument.Bookmarks.Count '返回当前文档中的书签数
(28) ActiveDocument.Characters.Count '返回当前文档的字符数
(29) ActiveDocument.CodeName ‘返回当前文档的代码名称
(30) ActiveDocument.Comments.Count ‘ 返回当前文档中的评论数
(31) ActiveDocument.Endnotes.Count '返回当前文档中的尾注数
(32) ActiveDocument.Fields.Count '返回当前文档中的域数目
(33) ActiveDocument.Footnotes.Count ‘返回当前文档中的脚注数
(34) ActiveDocument.FullName '返回当前文档的全名及所在位置
(35) ActiveDocument.HasPassword '当前文档是否有密码保护
(36) ActiveDocument.Hyperlinks.Count '返回当前文档中的链接数
(37) ActiveDocument.Indexes.Count '返回当前文档中的索引数
(38) ActiveDocument.ListParagraphs.Count '返回当前文档中项目编号或项目符号数
(39) ActiveDocument.ListTemplates.Count '返回当前文档中使用的列表模板数
(40) ActiveDocument.Paragraphs.Count '返回当前文档中的段落数
(41) ActiveDocument.Password=XXX '设置打开文件使用的密码
(42) ActiveDocument.ReadOnly '获取当前文档是否为只读属性
(43) ActiveDocument.Saved '当前文档是否被保存
(44) ActiveDocument.Sections.Count '当前文档中的节数
(45) ActiveDocument.Sentences.Count ‘当前文档中的语句数
(46) ActiveDocument.Shapes.Count '当前文档中的形状数 ,图形？
(47) ActiveDocument.Styles.Count '当前文档中的样式数
(48) ActiveDocument.Tables.Count ‘当前文档中的表格数
(49) ActiveDocument.TablesOfAuthorities.Count ‘返回当前文档中的引文目录数
(50) ActiveDocument.TablesOfAuthoritiesCategories.Count ‘返回当前文档中引文目录类别数
(51) ActiveDocument.TablesOfContents.Count ‘返回当前文档中的目录数
(52) ActiveDocument.TablesOfFigures.Count '返回当前文档中的图表目录数

3、Paragraphs/Paragraph对象
(53) Selection.Paragraphs.Count '返回所选区域的段落数
(54) Selection.Paragraphs.First '返回所选区域中的第一段
(55) ActiveDocument.Paragraphs(1).LeftIndent '返回当前文档中第一段的左缩进值
(56) ActiveDocument.Paragraphs(1).LineSpacing '返回当前文档中第一段的行距
(57) ActiveDocument.Paragraphs(1).OutlineLevel ‘返回或设置当前文档中第一段的大纲级别
.OutlineLevel = wdOutlineLevel2 ‘2级
.OutlineLevel = wdOutlineLevel3 ‘3级
(58) ActiveDocument.Paragraphs(1).RightIndent ‘返回当前文档中第一段的右缩进量
(59) ActiveDocument.Paragraphs(1).SpaceBefore '返回当前文档中第一段的段前间距
(60) ActiveDocument.Paragraphs(1).SpaceAfter ‘返回当前文档中第一段的段后间距
(61) ActiveDocument.Paragraphs(1).Range.Text '返回当前文档中第一段的内容
(62) ActiveDocument.Paragraphs(1).Range.Style.NameLocal '返回当前文档中第一段应用的样式名
(63) ActiveDocument.Paragraphs(1).Range.Style.Description '返回当前文档中第一段所应用样式的详细描述
(64) ActiveDocument.Paragraphs(1).Range.Style.Font.Name '返回当前文档中第一段所应用样式的字体名
(65) ActiveDocument.Paragraphs(1).Range.Style.Font.NameFarEast '返回或设置一种东亚字体名
(66) ActiveDocument.Paragraphs(1).Range.Style.Font.Size '返回或设置当前文档中第一段所应用样式的字体大小
(67) ActiveDocument.Paragraphs(1).Range.Style.Font.Spacing '返回或设置字符间距
(68) Selection.Words.Count '所选区域的字数 Sentences对象
(69) Selection.Sentences.Item(1) '所选区域中的第一句的内容 Words对象
(71) ActiveDocument.Words(1).Select '选择当前文档中的第一个词
(72) ActiveDocument.Range.Words(1).InsertAfter "我爱你！" '在当前文档中的第一个词后插入“我爱你”

4、Characters对象
(73) Selection.Characters.Count '当前文档中所选区域的字符数
(74) ActiveDocument.Paragraphs(1).Range.InsertParagraphAfter'在当前文档的第一段之后插入一个新段落

5、Sections/Section对象
(75) ActiveDocument.Sections.First '当前文档的第一节
(76) ActiveDocument.Sections.First.PageSetup.BottomMargin '当前文档第一节所在页的底边距
(77) ActiveDocument.Sections.First.PageSetup.LeftMargin '当前文档第一节所在页的左边距
(78) ActiveDocument.Sections.First.PageSetup.RightMargin '当前文档第一节所在页的右边距
(79) ActiveDocument.Sections.First.PageSetup.TopMargin '当前文档第一节所在页的顶边距
(80) ActiveDocument.Sections.First.PageSetup.PaperSize '返回或设置当前文档第一节所在页的大小
(81) ActiveDocument.Sections.First.PageSetup.PageHeight '返回或设置当前文档第一节所在页的高度
(82) ActiveDocument.Sections.First.PageSetup.PageWidth '返回或设置当前文档第一节所在页的宽度
(83) ActiveDocument.Sections.Add Range:=myRange '在当前文档中添加新节
(84) ActiveDocument.Sections.Item(2) '当前文档中的第二节
(85) ActiveDocument.Sections.Last.Range.InsertAfter "文档结束！" '在当前文档中最后一节的结尾添加文字“文档结束！”

6、Range对象
(86) ActiveDocument.Range(Start:=0, End:=10) '表示当前文档前10个字符所组成的一个Range对象
(87) Set myRange = ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(2).Range.Start, _
End:=ActiveDocument.Paragraphs(4).Range.End) '将当前文档第2段至第4段设置为一个Range对象
(88) ActiveDocument.Paragraphs(1).Range.Copy '复制当前文档中的第一段
(89) Selection.Copy
Documents.Add.Content.Paste '复制所选内容到新文档中
(90) ActiveDocument.Bookmarks("Book1").Copy Name:="Book2" '将Book2书签复制Book1书签标记的位置
(91) Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=4 '将所选内容移至文档中的第4行
(92) Selection.GoTo What:=wdGoToTable, Which:=wdGoToNext '将所选内容移至下一个表格的第1个单元格
(93) Selection.Range.AutoFormat '为所选内容套用格式
(94) ActiveDocument.Content.Font.Name = "Arial" '将当前文档的字体设置为斜体
(95) ActiveDocument.Content.Select Selection.Delete '将当前文档中的内容删除其它
(96) Documents.Add '添加一个新文档
(97) Set myTable = ActiveDocument.Tables.Add(Selection.Range, 2, 2) '在当前文档所选区域添加一个2行2列的表格

7、文件读写
(98) Open "C:\my.txt" For Input As #1 '打开一个用于输入的文件并令其编号为1
(99) Line Input #1, TextLine '读取被打开用于输入且编号为1的文件
(100) Close #1 '关闭编号为1的文件 参考技术A

下面的代码调试通过，是不是应该考虑加分：

Sub SAMPLE()
'批量添加打开文档密码
    Dim myDialog As FileDialog, oFile As Variant, oWord, oDoc
    'On Error Resume Next
    Dim myPassWord As String
    myPassWord = "tangqingfu"
    '定义一个文件夹选取对话框
    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = True    '允许多项选择
        If .Show <> -1 Then Exit Sub
        Set oWord = CreateObject("Word.Application")
        For Each oFile In .SelectedItems    '在所有选取项目中循环
            Set oDoc = oWord.Documents.Open(Filename:=oFile, Visible:=False)
            With oDoc
                .Password = myPassWord
                .Close True   '关闭文档
            End With
        Next oFile
        oWord.Quit
        Set oWord = Nothing
    End With
End Sub
Sub Example()
'批量解除打开文档密码
    Dim myDialog As FileDialog, oFile As Variant, oWord, oDoc
    Dim myPassWord As String
    'On Error Resume Next
    myPassWord = "tangqingfu"
    '定义一个文件夹选取对话框
    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = True    '允许多项选择
        If .Show <> -1 Then Exit Sub
        Set oWord = CreateObject("Word.Application")
        For Each oFile In .SelectedItems    '在所有选取项目中循环
            Set oDoc = oWord.Documents.Open(Filename:=oFile, Visible:=False, PasswordDocument:=myPassWord)
            With oDoc
                .ReadOnlyRecommended = False '请勿省略
                .Password = ""
                .Save
                .Close    '关闭文档
            End With
        Next oFile
        oWord.Quit
        Set oWord = Nothing
    End With
End Sub

追问

加分不成问题，能否再帮忙添加一个判断：在添加或解除密码时，如果文档本身有密码，肯定会报错的。加一个这样的判断：当有这样的情况发生时，忽略错误，程序继续运行，在程序结束后提醒：有？个文档未操作成功，文档名分别是：？？？

追答

字数超过，无法贴程序了，请下载附件，不会再有新要求吧~~~

 

追问

没有新要求了，不过在测试新的附件时，如果有不同的密码，能不能把这个要求输入密码的对话框去掉呀。

我加了：Application.DisplayAlerts = False，起不到什么效果。

追答

至少应该这样，能否成功我就不知道了：
oWord.Application.DisplayAlerts = False

追问

不成功，算了，估计应该很费事吧。

本回答被提问者采纳 参考技术B Sub GenDocfromExcel()

'excel控制word,生成新文件，插入图片和文件名，保存
'office 2003, VBA工具/引用中要勾选Microsoft Word 11.0 Object Library
'office 2007, VBA工具/引用中要勾选Microsoft Word 12.0 Object Library
'...

Range("A1:B13").Copy '复制当前内容

Dim WordApp As Word.Application '定义变量
Set WordApp = CreateObject("Word.Application") '生成WORD对象
WordApp.Documents.Add '新建文件

WordApp.Selection.Paste '粘贴

fn$ = "D:\" & Range("b1") '生成文件名
WordApp.ActiveDocument.SaveAs fn$ '保存文件

WordApp.Quit '退出
Set WordApp = Nothing '取消变量

End Sub