Board logo

标题: [问题求助] 【已解决】VBS如何合并多个文本至Excel(xls)的各个sheet中? [打印本页]

作者: elec    时间: 2014-8-28 22:30     标题: 【已解决】VBS如何合并多个文本至Excel(xls)的各个sheet中?

本帖最后由 elec 于 2014-8-29 08:12 编辑

假设当前有三个文本 aa.txt  bb.txt  cc.txt,文本的行数不定
将3文本合并至同一个Excel中:
将aa.txt的所有数据放在Excel的sheet1的第一列中,并把sheet1命名为aa
将bb.txt的所有数据放在Excel的sheet2的第一列中,并把sheet2命名为bb
将cc.txt的所有数据放在Excel的sheet3的第一列中,并把sheet3命名为cc
...
作者: yu2n    时间: 2014-8-29 00:19

沙发~
  1. On Error Resume Next
  2. arrTxtFile = Array("aa.txt", "bb.txt", "cc.txt")
  3. txt2excel arrTxtFile
  4. Function txt2excel(ByVal arrTxtFile)
  5. ' 创建 Excel 对象
  6. Set objExcel = CreateObject("Excel.Application")
  7. If Not Err.Number = 0 Then
  8. Msgbox "错误:无法创建 Excel 对象,你可能没有安装 Excel 。"
  9. Exit Function
  10. End If
  11. If Not objExcel.application.version >= 12.0 Then
  12. Msgbox "警告:请使用 Office 2007 以上版本。"
  13. End If
  14. ' 隐藏运行,屏蔽提示
  15. objExcel.Visible = False
  16. objExcel.DisplayAlerts = False
  17. ' 添加工作表
  18. Set objWorkBook = objExcel.Workbooks.Add
  19. ' Delete objWorkbook.Sheet(1-2)
  20. Do While objWorkBook.Worksheets.Count > 1
  21. objWorkBook.Worksheets(objWorkBook.Worksheets.Count).Delete
  22. Loop
  23. objWorkBook.Worksheets(objWorkBook.Worksheets.Count).Name = "TempTable"
  24. For i = UBound(arrTxtFile) To 0 STEP -1
  25. objWorkBook.Worksheets.Add.Name = i+1
  26. Next
  27. ' 向工作表写入 txt 文件内容
  28. For i = 0 To UBound(arrTxtFile)
  29. AddRow2Sheet objWorkBook.Worksheets(i+1), arrTxtFile(i)
  30. Next
  31. '''' Delete Sheet 3
  32.     If objWorkBook.Worksheets.Count > 1 Then objWorkBook.Worksheets("TempTable").Delete
  33. ' 显示 Excel
  34. objExcel.Visible = True
  35. set objExcel = NoThing
  36. End Function
  37. ' 向工作表写入 txt 文件内容
  38. Function AddRow2Sheet(ByRef objWorkSheet, ByVal FilePath)
  39. Dim fso, objTxt, strLine
  40. Set fso = CreateObject("Scripting.Filesystemobject")
  41. If Not fso.FileExists(FilePath) Then Exit Function
  42. ' 打开 Txt 文件,写入 Excel Sheet
  43. Set objTxt = fso.OpenTextFile(FilePath, 1)
  44. nLeft = 1 :  nTop = 1
  45. nRow = 0  :  nCol = 0
  46. Do Until objTxt.AtEndOfStream
  47. objWorkSheet.Rows(nTop + nRow).Insert
  48. objWorkSheet.Cells(nTop + nRow, nLeft + nCol).Value = objTxt.ReadLine
  49. nRow = nRow + 1
  50. Loop
  51. ' Sheet:重命名、名称冲突处理
  52. bReName = True
  53. strSheetName = Left(fso.GetFileName(FilePath), _
  54. Len(fso.GetFileName(FilePath)) - Len(fso.GetExtensionName(FilePath)) - 1)
  55. For Each objWorkSheet2 In objWorkSheet.Application.ActiveWorkBook.WorkSheets
  56. If objWorkSheet2.Name = strSheetName Then bReName = False
  57. Next
  58. If bReName Then objWorkSheet.Name = strSheetName
  59. objTxt.Close
  60. End Function
复制代码





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