Board logo

标题: [问题求助] [已解决]VBS怎样把多个excel所有工作表里的数据以工作表名保存为txt档? [打印本页]

作者: iq301    时间: 2014-8-8 20:57     标题: [已解决]VBS怎样把多个excel所有工作表里的数据以工作表名保存为txt档?

本帖最后由 iq301 于 2014-8-15 21:16 编辑

哎,现在的工作越来越繁锁,每天服务器生成的报告都是以excel方式出,所以,请问下,我要把多个excel所有工作表里的数据(或指定工作表的数据)按工作表命名全部保存为txt文本。能不能帮帮忙,我对VBS还在一个入门阶段,这样的水平写不出。。麻烦了
作者: iq301    时间: 2014-8-9 15:09

update~~?:loveliness:
作者: iq301    时间: 2014-8-10 00:37

update~~?
作者: Linuxer    时间: 2014-8-10 01:02

回复 3# iq301


    vbs不会。。帮你顶了,期待大神出手。
作者: yu2n    时间: 2014-8-10 23:35

Office 2007 +
生成的txt文件名格式:
excel全文件名+下划线+工作表名+txt文件名后缀
  1. ' 获取所有参数,请拖放所有Excel文件到本脚本文件(也可以将本脚本加入发送到菜单)
  2. For Each objArg In WScript.Arguments
  3.   Excel2Txt objArg
  4. Next
  5. Function Excel2Txt(FilePath)
  6.   On Error Resume Next
  7.   Set fso = CreateObject("Scripting.Filesystemobject")
  8.   If Not fso.FileExists(FilePath) Then Exit Function
  9.   
  10.   ' 创建 Excel 对象
  11.   Set objExcel = CreateObject("Excel.Application")
  12.   If Not Err.Number = 0 Then
  13.     Msgbox "错误:无法创建 Excel 对象,你可能没有安装 Excel 。"
  14.     Exit Function
  15.   End If
  16.   If Not objExcel.application.version >= 12.0 Then
  17.     Msgbox "警告:请使用 Office 2007 以上版本。"
  18.   End If
  19.   ' 隐藏运行,屏蔽提示
  20.   objExcel.Visible = False
  21.   objExcel.DisplayAlerts = False
  22.   
  23.   ' 打开 excel 文件,遍历所有工作表,保存为 Unicode txt
  24.   Const xlUnicodeText = 42
  25.   Set objWorkbook = objExcel.WorkBooks.Open(FilePath)
  26.   For Each objWorkSheet In objWorkbook.Worksheets
  27. ' 另存为 UnicodeText,改为其他格式,自行录制宏参考
  28.     objWorkSheet.SaveAs FilePath & "_" & objWorkSheet.Name & ".txt", _
  29.       xlUnicodeText, False
  30.   Next
  31.       
  32.   ' 退出
  33.   objExcel.Quit
  34.   If Not Err.Number = 0 Then Excel2Txt = True
  35. End Function
复制代码

作者: iq301    时间: 2014-8-11 01:57

回复 5# yu2n


    非常谢谢,但请问下怎么运行呢?
作者: yu2n    时间: 2014-8-11 09:04

回复 6# iq301
1. 打开记事本,复制代码,选保存,名称为 "0.vbs" (注意有双引号)。
2. 用鼠标左键选择多个excel文件,拖动到 0.vbs 文件上。
3. 神奇的事情发生了……
作者: iq301    时间: 2014-8-12 01:53

回复 7# yu2n


    谢谢,我明天回公司测试下,非常感谢哦,要是能做到双击就运行,更加好噶
作者: yu2n    时间: 2014-8-12 21:52

回复 8# iq301

1. 将代码存入脚本文件,使用鼠标左键双击来运行这个脚本文件。
2. 按提示选择一个文件夹。
3. 美好的事情即将发生……
  1. Main
  2. Sub Main()
  3.   Dim strPath, arrPath
  4.   strPath = BrowseForFolder("请选择 Excel 文件路径:")
  5.   If strPath = "" Then Exit Sub
  6.   arrPath = ScanFolder(strPath)
  7.   For Each strPath In arrPath
  8.     If LCase(Right(strPath,4))=".xlsx" Or LCase(Right(strPath,5))=".xlsx" Then
  9.       Excel2Txt strPath
  10.     End If
  11.   Next
  12. End Sub
  13. Function Excel2Txt(FilePath)
  14.   On Error Resume Next
  15.   Set fso = CreateObject("Scripting.Filesystemobject")
  16.   If Not fso.FileExists(FilePath) Then Exit Function
  17.   
  18.   ' 创建 Excel 对象
  19.   Set objExcel = CreateObject("Excel.Application")
  20.   If Not Err.Number = 0 Then
  21.     Msgbox "错误:无法创建 Excel 对象,你可能没有安装 Excel 。"
  22.     Exit Function
  23.   End If
  24.   If Not objExcel.application.version >= 12.0 Then
  25.     Msgbox "警告:请使用 Office 2007 以上版本。"
  26.   End If
  27.   ' 隐藏运行,屏蔽提示
  28.   objExcel.Visible = False
  29.   objExcel.DisplayAlerts = False
  30.   
  31.   ' 打开 excel 文件,遍历所有工作表,保存为 Unicode txt
  32.   Const xlUnicodeText = 42
  33.   Set objWorkbook = objExcel.WorkBooks.Open(FilePath)
  34.   For Each objWorkSheet In objWorkbook.Worksheets
  35.         ' 另存为 UnicodeText,改为其他格式,自行录制宏参考
  36.     objWorkSheet.SaveAs FilePath & "_" & objWorkSheet.Name & ".txt", _
  37.       xlUnicodeText, False
  38.   Next
  39.       
  40.   ' 退出
  41.   objExcel.Quit
  42.   If Not Err.Number = 0 Then Excel2Txt = True
  43. End Function
  44. Function BrowseForFolder(ByVal strTips)
  45.   Dim objFolder
  46.   Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
  47.   If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path  'objFolder.Items().Item().Path
  48. End Function
  49. Function ScanFolder(ByVal strPath)
  50.     Dim arr()
  51.     ReDim Preserve arr(0)
  52.     Call SCAN_FOLDER(arr, strPath)
  53.     ReDim Preserve arr(UBound(arr) - 1)
  54.     ScanFolder = arr
  55. End Function
  56. Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
  57.     On Error Resume Next
  58.     Dim fso, objItems, objFile, objFolder
  59.     Set fso = CreateObject("Scripting.FileSystemObject")
  60.     Set objItems = fso.GetFolder(folderSpec)
  61.     If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
  62.     If (Not fso.FolderExists(folderSpec)) Then Exit Function
  63.     For Each objFile In objItems.Files
  64.         arr(UBound(arr)) = objFile.Path
  65.         ReDim Preserve arr(UBound(arr) + 1)
  66.     Next
  67.     For Each objFolder In objItems.subfolders
  68.         Call SCAN_FOLDER(arr, objFolder.Path)
  69.     Next
  70.     arr(UBound(arr)) = folderSpec
  71.     ReDim Preserve arr(UBound(arr) + 1)
  72. End Function
复制代码

作者: iq301    时间: 2014-8-14 01:46     标题: RE: VBS怎样把多个excel所有工作表里的数据以工作表名保存为txt档?

回复 9# yu2n


    谢谢你的热心帮助,问题完美解决。啦
作者: CrLf    时间: 2014-8-14 02:20

回复 10# iq301


    那就结帖吧~在标题前面加个 [已解决] 就行
    有空的话顺便给满意的回复加个分什么的




欢迎光临 批处理之家 (http://bathome.net./) Powered by Discuz! 7.2