[新手上路]批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动[批处理精品]CMD命令50条不能说的秘密[在线下载]第三方命令行工具[在线帮助]VBScript / JScript 在线参考
返回列表 发帖

[文本处理] 批处理怎样批量修改Excel文档?

我想打开一个Exel文件,然后改变里面的一些内容,但是我这里有1500个Excel文档。都是同样的位置需要修改,问一下批处理可以实现吗?大神帮帮忙!!万分感谢!!

首先请发个样板上来。
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

就是每一个Excel文件中的A列8行加上“(工资条如下:)”这几个字,其他部分不变

TOP

本帖最后由 yu2n 于 2014-12-1 08:14 编辑

[更新:加入程序运行耗时统计。 2014.12.01.R1]
使用VBS完成以下需求:
1. 修改指定目录下所有Excel文档的ActiveSheet单元格A8内容
2. 修改指定目录下所有Excel文档的所有Sheet单元格A8内容(取消代码45~48行注释)
代码如下:
  1. CommandMode "VBS 批量修改Excel  By  Yu2n@qq.com"
  2. Main
  3. Sub Main()
  4.   On Error Resume Next
  5.   ' 选择文件夹
  6.   Dim strFolder, arrPath, strPath, nFileCount, i
  7.   Dim objExcel, dtStart
  8.   WScript.Echo "请选择 Excel 文件路径:"
  9.   strFolder = BrowseForFolder("请选择 Excel 文件路径:")
  10.   If strFolder = "" Then Exit Sub
  11.   arrPath = ScanFolder(strFolder)
  12.   ' 统计XLS、XLSX个数,用于显示进度
  13.   For Each strPath In arrPath
  14.     If LCase(Right(strPath,4))=".xls" Or LCase(Right(strPath,5))=".xlsx" Then
  15.       nFileCount = nFileCount + 1
  16.     End If
  17.   Next
  18.   ' 执行转换
  19.   dtStart = Now()
  20.   Set objExcel = Excel_Init()
  21.   For Each strPath In arrPath
  22.     If LCase(Right(strPath,4))=".xls" Or LCase(Right(strPath,5))=".xlsx" Then
  23.       i = i + 1
  24.       ' 显示进度
  25.       WScript.Echo "[" & i & "/" & nFileCount & "]" & strPath
  26.       ' 执行修改
  27.       Change_Excel objExcel, strPath
  28.     End If
  29.   Next
  30.   objExcel.Quit
  31.   WScript.Echo nFileCount & " 个文档完成修改,耗时 " & DateDiff("s",dtStart,Now()) & " 秒。"
  32.   Msgbox nFileCount & " 个文档完成修改,耗时 " & DateDiff("s",dtStart,Now()) & " 秒。", vbInformation + vbOKOnly, WScript.ScriptName
  33. End Sub
  34. ' 打开XLS/XLSX,修改A8并保存
  35. Function Change_Excel(objExcel, FilePath)
  36.   On Error Resume Next
  37.   Dim objWorkBook
  38.   Set objWorkBook = objExcel.Workbooks.Open(FilePath)
  39.   ' 修改XLS/XLSX活动Sheet
  40.   WScript.Echo objWorkBook.ActiveSheet.Range("A8")
  41.   objWorkBook.ActiveSheet.Range("A8") = "(工资条如下:)"
  42.   ' 修改XLS/XLSX所有Sheet
  43.   'For i = 1 To objWorkBook.Worksheets.Count
  44.   '  WScript.Echo objWorkBook.ActiveSheet.Range("A8")
  45.   '  objWorkBook.Worksheets(i).Range("A8") = "(工资条如下:)"
  46.   'Next
  47.   objWorkBook.Save
  48.   objWorkBook.Close False
  49.   Set objWorkBook = Nothing
  50.   If Not Err.Number = 0 Then Change_Excel = True
  51. End Function
  52. ' 创建 Excel 对象
  53. Function Excel_Init()
  54.   On Error Resume Next
  55.   Const msoAutomationSecurityForceDisable = 3
  56.   Set objExcel = CreateObject("Excel.Application")
  57.   If Not Err.Number = 0 Then
  58.     Msgbox "错误:无法创建 Excel 对象,你可能没有安装 Excel 。"
  59.     Exit Function
  60.   End If
  61.   If Not objExcel.application.version >= 12.0 Then
  62.     Msgbox "警告:请使用 Office 2007 以上版本。"
  63.   End If
  64.   objExcel.Visible = False
  65.   objExcel.DisplayAlerts = False
  66.   objExcel.AutomationSecurity = msoAutomationSecurityForceDisable
  67.   Set Excel_Init = objExcel
  68. End Function
  69. ' 以命令提示符环境运行(保留参数)
  70. Sub CommandMode(ByVal sTitle)
  71.   If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then
  72.     Dim i, sArgs
  73.     For i = 1 To WScript.Arguments.Count
  74.       sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"
  75.     Next
  76.     CreateObject("WScript.Shell").Run( _
  77.       "cmd /c Title " & sTitle & " &cscript.exe //NoLogo  """ & _
  78.       WScript.ScriptFullName & """ " & sArgs & " &pause"),3
  79.       Wscript.Quit
  80.   End If
  81. End Sub
  82. ' 浏览文件夹
  83. Function BrowseForFolder(ByVal strTips)
  84.   Dim objFolder
  85.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  86.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
  87. End Function
  88. ' 获取文件夹所有文件夹、文件列表(数组)
  89. Function ScanFolder(ByVal strPath)
  90.   Dim arr() : ReDim Preserve arr(-1)
  91.   Call SCAN_FOLDER(arr, strPath) : ScanFolder = arr
  92. End Function
  93. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
  94.   On Error Resume Next
  95.   Dim fso, objItems, objFile, objFolder
  96.   Set fso = CreateObject("Scripting.FileSystemObject")
  97.   Set objItems = fso.GetFolder(folderSpec)
  98.   If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
  99.   If (Not fso.FolderExists(folderSpec)) Then Exit Function
  100.   For Each objFile In objItems.Files
  101.     ReDim Preserve arr(UBound(arr) + 1)
  102.     arr(UBound(arr)) = objFile.Path
  103.   Next
  104.   For Each objFolder In objItems.subfolders
  105.     Call SCAN_FOLDER(arr, objFolder.Path)
  106.   Next
  107.   ReDim Preserve arr(UBound(arr) + 1)
  108.   arr(UBound(arr)) = folderSpec
  109. End Function
复制代码
3

评分人数

    • tokikou: 大牛技术 + 1
    • amwfjhh: 思路,代码风格都值得学习。技术 + 1
    • CrLf: 尿了技术 + 1
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

回复 4# yu2n


    太牛了!!十分感谢!

TOP

返回列表