如何用代码将当前文件下的除当前文件外的全部excel文档内容仅保留格式和值？

楼主 kevinchengcw	Q: 如何用代码将当前文件下的除当前文件外的全部excel文档内容仅保留格式和值？ A: 当前文件下的除当前文件外的全部excel文档内容仅保留格式和值的最快方法是创建一个当前文件的副本，仅复制格式及单元格值到副本中，并删除原本（当然也可以是改名备份），将副本重命名为原本的名字，涉及到下列知识点： 1. 获取文件列表的方法（含全部子文件夹）。 2. 循环读取文件并写入副本。 3. 相关信息的清理。本例示例代码如下： Sub test() Dim FN As String Dim Wb, Wb2 As Workbook Dim Ws As Worksheet Dim Rng As Range Dim Na As Name Dim N As Integer Dim Obj Application.ScreenUpdating = False '关闭屏幕刷新 Obj = CreateObject("WSCript.shell").Run("cmd.exe /c dir """ & ThisWorkbook.Path & "\.xls"" /s/a/b>""" & ThisWorkbook.Path & "\list.txt""", 0, True) '引用脚本运行命令行程序取得当前目录下所有excel文件名，而且等到运行结束后再继续执行vba代码 Set Obj = CreateObject("Scripting.FileSystemObject").OpenTextFile(ThisWorkbook.Path & "\list.txt", 1) '利用FSO打开记录当前目录下excel文件的文本文档 FN = "" '初始化文件名字符串变量为空 Do Until Obj.AtEndOfStream '循环读取文本文件内容直到末尾 FN = Obj.readline '读取一行文本并赋值给文件名变量 If FN <> "" And FN <> ThisWorkbook.FullName Then '如果文件名不为空且不是当前文件名（注意是全路径的） Set Wb = Workbooks.Open(FN) '则打开该文档（源文档） N = Wb.Worksheets.Count '取得该文档的工作表数 Application.SheetsInNewWorkbook = N '设定新建excel的工作表数其相同 Set Wb2 = Workbooks.Add '新建一个excel文档（新文档） Wb.Activate '激活源文档（有时不激活就操作会出错） For N = 1 To Wb.Worksheets.Count '循环源文档各工作表 Application.CutCopyMode = True '打开复制粘贴模式 Wb.Worksheets(N).Activate '激活源文档当前工作表 Wb.Worksheets(N).Unprotect '取消工作表保护 Wb.Worksheets(N).Cells.Copy '复制当前工作表全部单元格内容 Wb2.Activate '激活新文档 Wb2.Worksheets(N).Activate '激活新文档中对应的工作表 Wb2.Worksheets(N).Cells.Select '选定全部单元格（这样操作多数系统不会出问题） Wb2.Worksheets(N).Paste '粘贴从源文档中复制的内容 For Each Rng In Wb2.Worksheets(N).UsedRange '再循环新文档当前工作表中已使用范围中的各个单元格 If Rng.Value = "" Then '如果单元格的值为空则 Rng = "" Else '否则等于单元格的值（清除公式，链接等） Rng = Rng.Value End If Next Rng Application.CutCopyMode = False '关闭复制粘贴模式（这样可以清空剪贴板，避免提示有大量数据存放于剪贴板） Next N Wb.Close False '关闭源文档 Kill FN '删除源文档，如果不想删除这里可以更改成改名 Wb2.SaveAs FN '将新文档存为源文档的名 Wb2.Close '关闭新文档 End If Loop Obj.Close '关闭文本文件 Set Obj = Nothing '清空项目 Kill ThisWorkbook.Path & "\list.txt" '删除列表文件 Application.SheetsInNewWorkbook = 3 '恢复新建文件中工作表数量 Application.CutCopyMode = True '恢复复制粘贴模式 Application.DisplayAlerts = True '打开警告信息 Application.ScreenUpdating = True '打开屏幕刷新 End Sub 附示例文件。注：将示例文件放入要处理的文件夹内，打开文件，启用宏后点击处理按钮即可。处理程序.rar
2楼 wnianzhong	谢谢分享,学习了!
3楼 Lucy_Luk	C:\Users\user\Desktop\QQ截图20130906103322.jpg 運行出錯，說數字只能1-250之間，如何修改，tks~
4楼 icenotcool