[已解决]批量清除指定工作薄的问题

晓敏

附件 批量清除指定工作薄.rar (294.21 KB, 下载次数: 15)

2016-4-14 18:04 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

爱疯

2016-4-15 11:34

晓敏 发表于 2016-4-15 09:52
谢谢老师关注。题意是：让A字头命名的所有工作薄文件消失。

用DOS命令删除，可以吗？
如果目的目录是d:\abc，在ms-dos窗口里输入：

C:\>del d:\abc\a* /s

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. aa ThisWorkbook.Path & ""
   
3. End Sub
   
4. Sub aa(p)
   
5. Set fs = CreateObject("scripting.FileSystemObject")
   
6. Application.ScreenUpdating = False
   
7. For Each f In fs.GetFolder(p).Files
   
8.     If f Like "*.xls*" Then
   
9.         x = Split(f, "")
   
10.         If Left(x(UBound(x)), 1) = "A" Then
    
11.             With Workbooks.Open(f)
    
12.                 For Each sht In .Sheets
    
13.                     sht.UsedRange.ClearContents
    
14.                 Next
    
15.                 .Close 1
    
16.             End With
    
17.         End If
    
18.     End If
    
19. Next
    
20. For Each m In fs.GetFolder(p).SubFolders
    
21.     aa m
    
22. Next
    
23. Application.ScreenUpdating = True
    
24. End Sub

复制代码

晓敏

dsmch 发表于 2016-4-14 22:15

老师你好，谢谢帮助。试了一下，代码运行正常。但清除不了各子文件夹中的  A字头名命的工作薄。

爱疯

需求是清除A字头名命的工作薄中的所有工作表的数据，

还是删除A字头名命的工作薄文件？

晓敏

爱疯 发表于 2016-4-15 08:57
需求是清除A字头名命的工作薄中的所有工作表的数据，

还是删除A字头名命的工作薄文件？

谢谢老师关注。题意是：让A字头命名的所有工作薄文件消失。

爱疯

晓敏 发表于 2016-4-15 09:52
谢谢老师关注。题意是：让A字头命名的所有工作薄文件消失。

用DOS命令删除，可以吗？
如果目的目录是d:\abc，在ms-dos窗口里输入：

C:\>del d:\abc\a* /s

爱疯

Dim fso As Object    '模块级变量
Dim SourcePath As String
'主程序：通过递归，执行指定的操作
Sub main()
    Set fso = CreateObject("scripting.filesystemobject")
    SourcePath = getFolderPath("请选择源路径")
    If SourcePath = "" Then End
    Call Recursion(SourcePath)
End Sub

'获取文件夹路径
Function getFolderPath(prompt) As String
    Dim Objshell As Object, Objfolder As Object
    Set Objshell = CreateObject("Shell.Application")
    Set Objfolder = Objshell.BrowseForFolder(0, prompt, 0, 0)
    If Objfolder Is Nothing Then getFolderPath = "" Else getFolderPath = Objfolder.self.Path
    Set Objfolder = Nothing: Set Objshell = Nothing
End Function

'递归程序
Sub Recursion(myPath As String)
    Dim myFolder As Object, mySubFolder As Object, myFile As Object, x
    Set myFolder = fso.getfolder(myPath)
    '遍历文件夹
    For Each mySubFolder In myFolder.SubFolders
        Recursion mySubFolder.Path
    Next
    '遍历文件
    For Each myFile In myFolder.Files
        x = Left(fso.GetBaseName(myFile), 1)
        If x = "A" Or x = "a" Then fso.DeleteFile myFile
    Next
End Sub

1.rar (8.91 KB, 下载次数: 7)

2016-4-15 11:47 上传

点击文件名下载附件

dsmch

删除文件……
Sub Macro1()
aa ThisWorkbook.Path & "\"
End Sub
Sub aa(p)
Set fs = CreateObject("scripting.FileSystemObject")
Application.ScreenUpdating = False
For Each f In fs.GetFolder(p).Files
    If f Like "*.xls*" Then
        x = Split(f, "\")
        If Left(x(UBound(x)), 1) = "A" Then Kill f
    End If
Next
For Each m In fs.GetFolder(p).SubFolders
    aa m
Next
Application.ScreenUpdating = True
End Sub

dsmch

看附件结果

晓敏

dsmch 发表于 2016-4-15 19:32
看附件结果

我把  删除文件  四个字也复进去了。难怪运行不正常。
谢谢老师。