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

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

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

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

回复 10# iq301


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

TOP

RE: VBS怎样把多个excel所有工作表里的数据以工作表名保存为txt档?

回复 9# yu2n


    谢谢你的热心帮助,问题完美解决。啦

TOP

回复 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
复制代码
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

回复 7# yu2n


    谢谢,我明天回公司测试下,非常感谢哦,要是能做到双击就运行,更加好噶

TOP

回复 6# iq301
1. 打开记事本,复制代码,选保存,名称为 "0.vbs" (注意有双引号)。
2. 用鼠标左键选择多个excel文件,拖动到 0.vbs 文件上。
3. 神奇的事情发生了……
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

回复 5# yu2n


    非常谢谢,但请问下怎么运行呢?

TOP

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
复制代码
『千江有水千江月』千江有水,月映千江;万里无云,万里青天。    http://yu2n.qiniudn.com/

TOP

回复 3# iq301


    vbs不会。。帮你顶了,期待大神出手。

TOP

update~~?

TOP

update~~?:loveliness:

TOP

返回列表