On Error Resume Next
arrTxtFile = Array("aa.txt", "bb.txt", "cc.txt")
txt2excel arrTxtFile

Function txt2excel(ByVal arrTxtFile)

	' 创建 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

	' 添加工作表
	Set objWorkBook = objExcel.Workbooks.Add
	' Delete objWorkbook.Sheet(1-2)
	Do While objWorkBook.Worksheets.Count > 1
		objWorkBook.Worksheets(objWorkBook.Worksheets.Count).Delete
	Loop
	objWorkBook.Worksheets(objWorkBook.Worksheets.Count).Name = "TempTable"
	For i = UBound(arrTxtFile) To 0 STEP -1
		objWorkBook.Worksheets.Add.Name = i+1
	Next
	
	' 向工作表写入 txt 文件内容
	For i = 0 To UBound(arrTxtFile)
		AddRow2Sheet objWorkBook.Worksheets(i+1), arrTxtFile(i)
	Next

	'''' Delete Sheet 3
    If objWorkBook.Worksheets.Count > 1 Then objWorkBook.Worksheets("TempTable").Delete
	
	' 显示 Excel 
	objExcel.Visible = True
	set objExcel = NoThing
	
End Function


' 向工作表写入 txt 文件内容
Function AddRow2Sheet(ByRef objWorkSheet, ByVal FilePath)
	Dim fso, objTxt, strLine
	Set fso = CreateObject("Scripting.Filesystemobject")
	If Not fso.FileExists(FilePath) Then Exit Function
	' 打开 Txt 文件，写入 Excel Sheet
	Set objTxt = fso.OpenTextFile(FilePath, 1)
	nLeft = 1 :  nTop = 1
	nRow = 0  :  nCol = 0
	Do Until objTxt.AtEndOfStream
		objWorkSheet.Rows(nTop + nRow).Insert
		objWorkSheet.Cells(nTop + nRow, nLeft + nCol).Value = objTxt.ReadLine
		nRow = nRow + 1
	Loop
	' Sheet：重命名、名称冲突处理
	bReName = True
	strSheetName = Left(fso.GetFileName(FilePath), _
						Len(fso.GetFileName(FilePath)) - Len(fso.GetExtensionName(FilePath)) - 1)
	For Each objWorkSheet2 In objWorkSheet.Application.ActiveWorkBook.WorkSheets
		If objWorkSheet2.Name = strSheetName Then bReName = False
	Next
	If bReName Then objWorkSheet.Name = strSheetName
	objTxt.Close
End Function
复制代码