[问题求助] 如何用vbs将excel表格的某一行数据提取出来另存csv文件？

siweiqi

如何用vbs将excel表格的某一行数据提取出来另存csv文件？

34205

XUE XI L E A  AAAAAAAAAAAA

yu2n

VBS 提取Excel第七行存入CSV文件

CommandMode "VBS 提取Excel第七行存入CSV文件  By  Ｙu２n＠qq.com"

Main
Sub Main()
  On Error Resume Next
  ' 选择文件夹
  Dim strFolder, arrPath, strPath, nFileCount, i
  WScript.Echo "请选择 Excel 文件路径："
  strFolder = BrowseForFolder("请选择 Excel 文件路径：")
  If strFolder = "" Then Exit Sub
  arrPath = ScanFolder(strFolder)
  ' 统计XLS、XLSX个数，用于显示进度
  For Each strPath In arrPath
    If LCase(Right(strPath,4))=".xls" Or LCase(Right(strPath,5))=".xlsx" Then
      nFileCount = nFileCount + 1
    End If
  Next
  ' 执行转换
  Dim dtStart, objExcel
  dtStart = Now()
  Set objExcel = Excel_Init()
  For Each strPath In arrPath
    If LCase(Right(strPath,4))=".xls" Or LCase(Right(strPath,5))=".xlsx" Then
      i = i + 1
      ' 显示进度
      WScript.Echo "[" & i & "/" & nFileCount & "]" & strPath
      ' 提取Excel第七行存入CSV文件
      Change_Excel objExcel, strPath
    End If
  Next
  objExcel.Quit
  WScript.Echo nFileCount & " 个文档完成，耗时 " & DateDiff("s",dtStart,Now()) & " 秒。"
  Msgbox nFileCount & " 个文档完成，耗时 " & DateDiff("s",dtStart,Now()) & " 秒。", vbInformation+vbOKOnly, WScript.ScriptName
End Sub

' 打开XLS/XLSX，提取Excel第七行存入CSV文件
Function Change_Excel(ByVal objExcel, ByVal FilePath)
  On Error Resume Next
  Const xlCSV = 6
  Dim objWorkBook, strNew, strOld
  Set objWorkBook = objExcel.Workbooks.Open(FilePath)
  Set objWorkbook1 = objExcel.Workbooks.Add
  ' 修改XLS/XLSX活动Sheet
  objWorkBook.ActiveSheet.Rows("7:7").Copy _
    objWorkBook1.ActiveSheet.Rows("7:7")
  objWorkBook.Close False
  objWorkBook1.SaveAs _
      FilePath & ".csv", xlCSV, False
  objWorkBook1.Close False
  Set objWorkBook = Nothing
  If Not Err.Number = 0 Then Change_Excel = True
End Function

' 创建 Excel 对象
Function Excel_Init()
  On Error Resume Next
  Const msoAutomationSecurityForceDisable = 3
  Set objExcel = CreateObject("Excel.Application")
  If Not Err.Number = 0 Then
    Msgbox "错误：无法创建 Excel 对象，你可能没有安装 Excel 。", vbCritical+vbOKOnly, WScript.ScriptName
    WScript.Quit(999)
  End If
  If Not objExcel.application.version >= 12.0 Then
    Msgbox "警告：请使用 Office 2007 以上版本。", vbExclamation+vbOKOnly, WScript.ScriptName
  End If
  ' 隐藏运行，屏蔽提示
  objExcel.Visible = False
  objExcel.DisplayAlerts = False
  objExcel.AutomationSecurity = msoAutomationSecurityForceDisable
  Set Excel_Init = objExcel
End Function

' 以命令提示符环境运行(保留参数)
Sub CommandMode(ByVal sTitle)
  If (LCase(Right(WScript.FullName,11)) = "wscript.exe") Then
    Dim i, sArgs
    For i = 1 To WScript.Arguments.Count
      sArgs = sArgs & " " & """" & WScript.Arguments(i-1) & """"
    Next
    CreateObject("WScript.Shell").Run( _
      "cmd /c Title " & sTitle & " &cscript.exe //NoLogo  """ & _
      WScript.ScriptFullName & """ " & sArgs & " &pause"),3
      WScript.Quit
  End If
End Sub

' 浏览文件夹
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(-1)
  Call SCAN_FOLDER(arr, strPath) : 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
    ReDim Preserve arr(UBound(arr) + 1)
    arr(UBound(arr)) = objFile.Path
  Next
  For Each objFolder In objItems.subfolders
    Call SCAN_FOLDER(arr, objFolder.Path)
  Next
  ReDim Preserve arr(UBound(arr) + 1)
  arr(UBound(arr)) = folderSpec
End Function
复制代码