這邊有測試了xgtcarter提供的程式，在分行的部分好像有一些問題。
不過也發現原本的CSV檔中，有空行跟不對稱的資料欄位
還在想辦法處理。

謝謝 xgtcarter 的指導。

如果分行有問題的地方沒辦法解決的話,可以把csv檔找個空間上傳上去,
我再根據實際完整的csv檔去做例外排除解析,看是要全放在一個cell還是另外處理,因為當初的script是在沒有實際的csv資料的情況下寫出來的,所以產出的檔案一定會有些落差的.

感謝xgtcarter先進這麼熱心的協助，還是您可以提供E-Mail給我，我將範例檔案壓縮寄送讓您看看(17.4K左右)？

已私訊我的E-Mail了

由於csv內容及格式繁雜,所以可能要確認一下有沒有轉錯的

Option Explicit

Const ForReading = 1

Dim strCurPath, strXlsOutput, objExcel, wshFSO, strCsvPath
Dim objCsvFolder, objCsvFile, txtStream, arrStr, x, y, s
Dim strTmp, strLine

strCurPath = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\"))
strCsvPath = strCurPath & "CSV\"
strXlsOutput = strCurPath & "Csv2Excel.xlsx"
Set objExcel = CreateObject("Excel.Application")
Set wshFSO = CreateObject("Scripting.FileSystemObject")
If Not wshFSO.FolderExists(strCsvPath) Then
    Wscript.Echo "CSV Folder : " & vbNewLine & strCsvPath & vbNewLine & "Not Exists!"
    Wscript.Quit
End If
Set objCsvFolder = wshFSO.GetFolder(strCsvPath)
With objExcel
    .Application.Visible = False
    If wshFSO.FileExists(strXlsOutput) Then
        wshFSO.DeleteFile strXlsOutput
    End If
    .Workbooks.Add
    For Each objCsvFile In objCsvFolder.Files
        s = s + 1
        If .Sheets.Count < S Then .Sheets.Add , .Sheets(.Sheets.Count)
        Set txtStream = objCsvFile.OpenAsTextStream(ForReading)
        y = 1
        Do While Not txtStream.AtEndOfStream
            strLine = txtStream.ReadLine
            If Right(strLine, 1) = Chr(34) And InStrRev(strLine, """,", -1) <> 0 Then
                strLine = strTmp & strLine
                strTmp = vbNullString
                arrStr = Split(Mid(strLine, 2, Len(strLine) - 2), """,""")
                For x = 0 To UBound(arrStr)
                    .Sheets(s).Cells(y, x + 1).Value = arrStr(x)
                Next
                y = y + 1
            Else
                strTmp = strTmp & strLine
            End If
        Loop
        .Worksheets(s).Name = objCsvFile.Name
    Next
    .ActiveWorkbook.SaveAs strXlsOutput
    .ActiveWorkbook.Close
    .Application.Quit
End With
Wscript.Echo "Excel File : " & vbNewLine & strXlsOutput & vbNewLine & " Output OK!"
Set objCsvFolder = Nothing
Set objCsvFile = Nothing
Set objExcel = Nothing
Set wshFSO = Nothing

這邊有小測試了一下，是可以轉的，非常感謝xgtcarter大力協助。
不過如果我要變更寫入Excel欄位的順序，我可以透過那個變數(或陣列）來改變呢？謝謝您！！

輸出的欄位順序是按照讀入的csv檔的內容順序產生的,沒有把欄位內容讀到獨立的陣列變數中,而是把它直接寫入excel的儲存格中,所以若要改變欄位出現的順序的話,就要從寫入儲存格的順序那邊下手,這可以用choose函數達到這個要求,以下列出有變動的程式碼

Dim strTmp, strLine, xNew
xNew = Choose(x + 1, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18)
.Sheets(s).Cells(y, xNew).Value = arrStr(x) )

欄位的部分可能要依實際輸出欄位數量調整(目前的範例是18),choose後面接的第一個變數是座標(index),後面是你想要的順序,預設就是沒有變動,假設我要把第一個跟第二欄位互換就是改成

xNew = Choose(x + 1, 2, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18)

其它的就依此類推

抱歉一直沒有時間測試
現在測試卻發生沒有定義變數CHOOSE的錯誤

抱歉,因為VBS本身不好Debug,我是在VB上面做測試再移植到VBS上,Choose這個函數VB上有但是VBS上沒有,所以會有這個錯誤,以下重新用另個方法取代,只列出有變動的部分程式碼:

Dim arrNew
arrNew = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18)
For x = 0 To UBound(arrStr)
    .Sheets(s).Cells(y, arrNew(x)).Value = arrStr(x)
Next

新增一個arrNew變數(用來存放之後的順序),順序變更方式一樣只要變更array(2,1,3,4....)中的順序即可,定義順序那行可以放在程式開頭的地方,定義變數的後面

執行會有類似無窮迴圈的情況發生， 因為一直沒有回應，且目錄中也不會產生出「Csv2Excel.xlsx」這個檔案。這樣還有可能是哪邊有錯誤嗎？謝謝您熱心指導。
不確定小弟是否有加錯您指導的那幾段程式，所以目前程式碼如下

Option Explicit

Const ForReading = 1

Dim strCurPath, strXlsOutput, objExcel, wshFSO, strCsvPath
Dim objCsvFolder, objCsvFile, txtStream, arrStr, x, y, s
Dim strTmp, strLine, xNew
Dim arrNew

strCurPath = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\"))
strCsvPath = strCurPath & "CSV\"
strXlsOutput = strCurPath & "Csv2Excel.xlsx"
Set objExcel = CreateObject("Excel.Application")
Set wshFSO = CreateObject("Scripting.FileSystemObject")
If Not wshFSO.FolderExists(strCsvPath) Then
    Wscript.Echo "CSV Folder : " & vbNewLine & strCsvPath & vbNewLine & "Not Exists!"
    Wscript.Quit
End If
Set objCsvFolder = wshFSO.GetFolder(strCsvPath)
With objExcel
    .Application.Visible = False
    If wshFSO.FileExists(strXlsOutput) Then
        wshFSO.DeleteFile strXlsOutput
    End If
    .Workbooks.Add
    For Each objCsvFile In objCsvFolder.Files
        s = s + 1
        If .Sheets.Count < S Then .Sheets.Add , .Sheets(.Sheets.Count)
        Set txtStream = objCsvFile.OpenAsTextStream(ForReading)
        y = 1
        Do While Not txtStream.AtEndOfStream
            strLine = txtStream.ReadLine
            If Right(strLine, 1) = Chr(34) And InStrRev(strLine, """,", -1) <> 0 Then
                strLine = strTmp & strLine
                strTmp = vbNullString
                arrStr = Split(Mid(strLine, 2, Len(strLine) - 2), """,""")
				arrNew = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18)
				For x = 0 To UBound(arrStr)
					.Sheets(s).Cells(y, arrNew(x)).Value = arrStr(x)
				Next
                y = y + 1
            Else
                strTmp = strTmp & strLine
            End If
        Loop
        .Worksheets(s).Name = objCsvFile.Name
    Next
    .ActiveWorkbook.SaveAs strXlsOutput
    .ActiveWorkbook.Close
    .Application.Quit
End With
Wscript.Echo "Excel File : " & vbNewLine & strXlsOutput & vbNewLine & " Output OK!"
Set objCsvFolder = Nothing
Set objCsvFile = Nothing
Set objExcel = Nothing
Set wshFSO = Nothing

arrNew = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18)
放在strCurPath = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, ""))前面

我找了兩台電腦進行測試，發現還是一樣無窮迴圈，也不會出現Excel檔案，請問還有可能是什麼原因嗎？
程式碼如下：

Option Explicit

Const ForReading = 1

Dim strCurPath, strXlsOutput, objExcel, wshFSO, strCsvPath
Dim objCsvFolder, objCsvFile, txtStream, arrStr, x, y, s
Dim strTmp, strLine, xNew, arrNew

arrNew = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18)
strCurPath = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\"))
strCsvPath = strCurPath & "CSV\"
strXlsOutput = strCurPath & "Csv2Excel.xlsx"
Set objExcel = CreateObject("Excel.Application")
Set wshFSO = CreateObject("Scripting.FileSystemObject")
If Not wshFSO.FolderExists(strCsvPath) Then
    Wscript.Echo "CSV Folder : " & vbNewLine & strCsvPath & vbNewLine & "Not Exists!"
    Wscript.Quit
End If
Set objCsvFolder = wshFSO.GetFolder(strCsvPath)
With objExcel
    .Application.Visible = False
    If wshFSO.FileExists(strXlsOutput) Then
        wshFSO.DeleteFile strXlsOutput
    End If
    .Workbooks.Add
    For Each objCsvFile In objCsvFolder.Files
        s = s + 1
        If .Sheets.Count < S Then .Sheets.Add , .Sheets(.Sheets.Count)
        Set txtStream = objCsvFile.OpenAsTextStream(ForReading)
        y = 1
        Do While Not txtStream.AtEndOfStream
            strLine = txtStream.ReadLine
            If Right(strLine, 1) = Chr(34) And InStrRev(strLine, """,", -1) <> 0 Then
                strLine = strTmp & strLine
                strTmp = vbNullString
                arrStr = Split(Mid(strLine, 2, Len(strLine) - 2), """,""")
                For x = 0 To UBound(arrStr)
					.Sheets(s).Cells(y, arrNew(x)).Value = arrStr(x)
REM					.Sheets(s).Cells(y, xNew).Value = arrStr(x)
REM                    .Sheets(s).Cells(y, x + 1).Value = arrStr(x)
                Next
                y = y + 1
            Else
                strTmp = strTmp & strLine
            End If
        Loop
        .Worksheets(s).Name = objCsvFile.Name
    Next
    .ActiveWorkbook.SaveAs strXlsOutput
    .ActiveWorkbook.Close
    .Application.Quit
End With
Wscript.Echo "Excel File : " & vbNewLine & strXlsOutput & vbNewLine & " Output OK!"
Set objCsvFolder = Nothing
Set objCsvFile = Nothing
Set objExcel = Nothing
Set wshFSO = Nothing