|
|
楼主 |
发表于 2016-5-11 13:47
|
显示全部楼层
本帖最后由 乐乐2006201506 于 2016-5-11 14:23 编辑
Option Explicit
Dim fso As Object '模块级变量
Dim SourcePath As String
'主程序：通过递归，执行指定的操作
Sub main()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set fso = CreateObject("scripting.filesystemobject")
'获取源路径
SourcePath = getFolderPath("请选择源路径")
If SourcePath = "" Then End
'递归
Call Recursion(SourcePath)
'显示结果
Shell "explorer " & SourcePath & "\", vbNormalFocus
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
Set myFolder = fso.getfolder(myPath)
'遍历文件夹
For Each mySubFolder In myFolder.SubFolders
Recursion mySubFolder.Path
Next
'遍历文件
For Each myFile In myFolder.Files
If fso.GetExtensionName(myPath & "\" & myFile) = "xls" Or _
fso.GetExtensionName(myPath & "\" & myFile) = "xlsm" Then
Call demo(myPath, myFile.Name)
End If
Next
End Sub
'指定的操作
Sub demo(myPath As String, myFile As String)
Dim wb As Workbook
Dim sh As Sheets
Dim rng As Range
Dim i As Integer
Dim arr As Variant
Dim c As Object
'1）清除公式
Set wb = Workbooks.Open(myPath & "\" & myFile)
For i = 1 To Sheets.Count
arr = Sheets(i).UsedRange
Sheets(i).UsedRange = arr 修改了这些地方后，可以完全实现清除公式的效果，但是身份证号码后四位都变为“0”了。怎么办？
Next
'2）删除指定文件中的代码和窗体
'遍历所有wb中所有部件
For Each c In wb.VBProject.VBComponents
'如果部件c是标准模块
If c.Type = 100 Then
'删除部件c第1行到最后1行的代码
c.CodeModule.DeleteLines 1, c.CodeModule.CountOfLines
Else
'从部件集合中删除部件c
wb.VBProject.VBComponents.Remove c
End If
Next
wb.Close True
Set wb = Nothing
End Sub |
|
楼主: 乐乐2006201506
IP卡
狗仔卡
显身卡
发表于 2016-5-11 15:51
