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

iq301

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

CrLf

回复 10# iq301


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

iq301

回复 9# yu2n


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

yu2n

回复 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

回复 7# yu2n


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

yu2n

回复 6# iq301
1. 打开记事本，复制代码，选保存，名称为 "0.vbs" （注意有双引号）。
2. 用鼠标左键选择多个excel文件，拖动到 0.vbs 文件上。
3. 神奇的事情发生了……

iq301

回复 5# yu2n


    非常谢谢，但请问下怎么运行呢？

yu2n

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
复制代码

Linuxer

回复 3# iq301


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

iq301

update~~?

iq301

update~~?:loveliness: