标题: [问题求助] [已解决]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文件名后缀- ' 获取所有参数,请拖放所有Excel文件到本脚本文件(也可以将本脚本加入发送到菜单)
- For Each objArg In WScript.Arguments
- Excel2Txt objArg
- Next
-
- Function Excel2Txt(FilePath)
-
- On Error Resume Next
- Set fso = CreateObject("Scripting.Filesystemobject")
- If Not fso.FileExists(FilePath) Then Exit Function
-
- ' 创建 Excel 对象
- Set objExcel = CreateObject("Excel.Application")
- If Not Err.Number = 0 Then
- Msgbox "错误:无法创建 Excel 对象,你可能没有安装 Excel 。"
- Exit Function
- End If
-
- If Not objExcel.application.version >= 12.0 Then
- Msgbox "警告:请使用 Office 2007 以上版本。"
- End If
-
- ' 隐藏运行,屏蔽提示
- objExcel.Visible = False
- objExcel.DisplayAlerts = False
-
- ' 打开 excel 文件,遍历所有工作表,保存为 Unicode txt
- Const xlUnicodeText = 42
- Set objWorkbook = objExcel.WorkBooks.Open(FilePath)
- For Each objWorkSheet In objWorkbook.Worksheets
- ' 另存为 UnicodeText,改为其他格式,自行录制宏参考
- objWorkSheet.SaveAs FilePath & "_" & objWorkSheet.Name & ".txt", _
- xlUnicodeText, False
- Next
-
- ' 退出
- objExcel.Quit
- If Not Err.Number = 0 Then Excel2Txt = True
- 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. 美好的事情即将发生……- Main
- Sub Main()
- Dim strPath, arrPath
- strPath = BrowseForFolder("请选择 Excel 文件路径:")
- If strPath = "" Then Exit Sub
- arrPath = ScanFolder(strPath)
- For Each strPath In arrPath
- If LCase(Right(strPath,4))=".xlsx" Or LCase(Right(strPath,5))=".xlsx" Then
- Excel2Txt strPath
- End If
- Next
- End Sub
-
- Function Excel2Txt(FilePath)
-
- On Error Resume Next
- Set fso = CreateObject("Scripting.Filesystemobject")
- If Not fso.FileExists(FilePath) Then Exit Function
-
- ' 创建 Excel 对象
- Set objExcel = CreateObject("Excel.Application")
- If Not Err.Number = 0 Then
- Msgbox "错误:无法创建 Excel 对象,你可能没有安装 Excel 。"
- Exit Function
- End If
-
- If Not objExcel.application.version >= 12.0 Then
- Msgbox "警告:请使用 Office 2007 以上版本。"
- End If
-
- ' 隐藏运行,屏蔽提示
- objExcel.Visible = False
- objExcel.DisplayAlerts = False
-
- ' 打开 excel 文件,遍历所有工作表,保存为 Unicode txt
- Const xlUnicodeText = 42
- Set objWorkbook = objExcel.WorkBooks.Open(FilePath)
- For Each objWorkSheet In objWorkbook.Worksheets
- ' 另存为 UnicodeText,改为其他格式,自行录制宏参考
- objWorkSheet.SaveAs FilePath & "_" & objWorkSheet.Name & ".txt", _
- xlUnicodeText, False
- Next
-
- ' 退出
- objExcel.Quit
- If Not Err.Number = 0 Then Excel2Txt = True
- End Function
-
-
- Function BrowseForFolder(ByVal strTips)
- Dim objFolder
- Set objFolder = CreateObject("Shell.Application").BrowseForFolder (&H0, strTips, &H0010 + &H0001)
- If (Not objFolder Is Nothing) Then BrowseForFolder = objFolder.Self.Path 'objFolder.Items().Item().Path
- End Function
-
-
- Function ScanFolder(ByVal strPath)
- Dim arr()
- ReDim Preserve arr(0)
- Call SCAN_FOLDER(arr, strPath)
- ReDim Preserve arr(UBound(arr) - 1)
- ScanFolder = arr
- End Function
- Function SCAN_FOLDER(ByRef arr, ByVal folderSpec)
- On Error Resume Next
- Dim fso, objItems, objFile, objFolder
- Set fso = CreateObject("Scripting.FileSystemObject")
- Set objItems = fso.GetFolder(folderSpec)
- If Right(folderSpec, 1) <> "\" Then folderSpec = folderSpec & "\"
- If (Not fso.FolderExists(folderSpec)) Then Exit Function
- For Each objFile In objItems.Files
- arr(UBound(arr)) = objFile.Path
- ReDim Preserve arr(UBound(arr) + 1)
- Next
- For Each objFolder In objItems.subfolders
- Call SCAN_FOLDER(arr, objFolder.Path)
- Next
- arr(UBound(arr)) = folderSpec
- ReDim Preserve arr(UBound(arr) + 1)
- 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 |