把多个CSV文件加载到一个EXCEL文件

 

Option Explicit

Const path1 = "C: emp"
Const path2 = "C: empCsvToExcel"
Const sPattern = "*.csv"

Private Sub Form_Load()

On Error GoTo err
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlSheet1 As Excel.Worksheet


Dim excelname As String
excelname = Replace(DateTime.Now, ":", "-") & ".xls"

'Write in log file
Dim logtxtfile As String
Dim excelfilename() As String
excelfilename = Split(excelname, ".")
logtxtfile = excelfilename(0)
' Dim sw As System.IO.StreamWriter = New StreamWriter(path2 & logtxtfile & ".txt")


  Set xlBook = xlApp.Workbooks.Add
'get all *.csv files
Dim csvPath As String
Dim csvPaths(1 To 30) As String
Dim xlsPath As String
Dim csvfilename As String
Dim csvfiles() As String
File1.Path = path1
File1.Pattern = sPattern

Dim i As Integer
For i = 0 To File1.ListCount - 1
    csvfilename = File1.List(i)
    csvPath = path1 & "" & csvfilename
    'csvPaths(i + 1) = csvPath
  
Set xlSheet = xlBook.Worksheets.Add()
xlSheet.Name = csvfilename
 'xlApp.ActiveSheet
Dim linesFromFile() As String
Dim NextLine As String
Dim dataStart, mapWidth As Integer

Open csvPath For Input As #1

'Open path2 + excelname For Output Access Write As #55
Dim rowCount As Long
rowCount = 0
Do While Not EOF(1)
    Line Input #1, NextLine
    linesFromFile() = Split(NextLine, ",")
    'Dim counter As Integer
    Dim WriteStrArrayI As Integer
    Dim lenLines As Integer
    lenLines = UBound(linesFromFile)
    rowCount = rowCount + 1
    For WriteStrArrayI = 0 To lenLines
      xlApp.Cells(rowCount, WriteStrArrayI + 1) = linesFromFile(WriteStrArrayI)
    Next
'Print #55, linesFromFile


Loop
'Set xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, WriteStrArrayI)).Font.Bold = True   '设置表头字体
'xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, WriteStrArrayI)).Interior.Color = 77777700 '设置表头颜色

Close #1

Next
Label1.Caption = csvPath

Set xlSheet1 = xlBook.Worksheets("sheet1")
xlSheet1.Delete
Set xlSheet1 = xlBook.Worksheets("sheet2")
xlSheet1.Delete
Set xlSheet1 = xlBook.Worksheets("sheet3")
xlSheet1.Delete

Dim savePath As String
savePath = path2 & excelname
xlApp.ActiveWorkbook.SaveAs (savePath)
xlApp.Quit
err:
If err.Description <> "" Then
    savePath = path2 & excelname
    xlApp.ActiveWorkbook.SaveAs (savePath)
    xlApp.Quit
End If
End Sub