【已解决】VBS如何合并多个文本至Excel（xls）的各个sheet中？

elec

假设当前有三个文本 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

沙发~

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

复制代码