[已解决]怎样阻止弹出窗口

乐乐2006201506

在运行过程中会出现下面窗口，如何使它不显示？谢谢！


Dim ArrFiles(1 To 100) '创建一个数组空间,用来存放文件名称
Dim cntFiles% '文件个数
Public Sub ListAllFiles()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

Dim strPath$                                                        '声明文件路径
Dim i%
'Set fso = CreateObject("Scripting.FileSystemObject")
Dim fso As New FileSystemObject, fd As Folder                       '创建一个FileSystemObject对象和一个文件夹对象
        strPath = "C:\Users\YYB\Desktop\写入代码多层子文件夹\花名册测试文件\" '"设置要遍历的文件夹目录
        cntFiles = 0
        Set fd = fso.GetFolder(strPath)                             '设置fd文件夹对象
        SearchFiles fd                                              '调用子程序查搜索文件
'        Sheets(1).Range("A1").Resize(cntFiles) = Application.Transpose(ArrFiles)      '把数组内的路径和文件名放在单元格中
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Sub SearchFiles(ByVal fd As Folder)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

Dim fl As File
Dim sfd As Folder
For Each fl In fd.Files                                        '通过循环把文件逐个放在数组内
cntFiles = cntFiles + 1
ArrFiles(cntFiles) = fl.Path
    If fl Like "*.xls" Then
        Workbooks.Open fl
        Call 读取公式并存入文本文件
'        ActiveWorkbook.SaveAs Filename:=strPath & Replace(fl, ".xls", ".xlsm"), FileFormat:=52
        ActiveWorkbook.Close False       '这句代码如果保存的话，会弹出是否保存的窗口，怎么消除
    End If
Next fl
If fd.SubFolders.Count = 0 Then Exit Sub                    'SubFolders返回由指定文件夹中所有子文件夹（包括隐藏文件夹和系统文件夹）组成的 Folders 集合
For Each sfd In fd.SubFolders                               '在 Folders 集合进行循环查找
SearchFiles sfd                                             '使用递归方法查找下一个文件夹
Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub 读取公式并存入文本文件()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim FormulaCells As Range, Cell As Range
    Dim FormulaSheet As Worksheet
    Dim Row As Integer, myfile$, objFolder
    Dim fso As Scripting.FileSystemObject
    Dim mt As Scripting.TextStream
    '创建Range对象
    On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
    Set FormulaCells = Range("A1").SpecialCells(xlFormulas, 23)
    '没有找到公式
    If FormulaCells Is Nothing Then
        MsgBox "当前工作表中没有公式！"
        Exit Sub
    End If
    mypath = "C:\Users\YYB\Desktop\写入代码多层子文件夹\文本文件公式\"
    myfile = mypath & "\" & Replace(ActiveWorkbook.Name, ".xlsm", "") & Replace(Replace(ActiveWorkbook.Path, "\", " "), ":", " ") & ".txt"
    Set fso = New Scripting.FileSystemObject
    Set mt = fso.CreateTextFile(Filename:=myfile, overwrite:=True)
    '读取公式，同时在状态栏中显示进度。
    For Each Cell In FormulaCells
        mt.Write Cell.Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
        mt.Write Cell.Formula & vbCrLf
    Next
    mt.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-25 09:05

打开工作簿的语句改一下

1. Workbooks.Open Filename:=filePth, UpdateLinks:=False

复制代码

跳转到最佳答案楼层

老司机带带我

打开工作簿的语句改一下

1. Workbooks.Open Filename:=filePth, UpdateLinks:=False

复制代码

乐乐2006201506

        借鉴您的方法，达到了目的，谢谢！（迟迟没有给你最佳答案的原因：前两天吃西瓜吃坏了肚子，上吐下泻折腾了一天一夜，昨晚狂吐后，才感觉舒服了一些，这会儿身体还是不适，但为了感谢您的帮助，打开电脑，试验后，自己借鉴您的方法，达到了效果，再次感谢！我最近问的大部分问题估计比较难，很多都是您解答的，不胜感激！）