iT邦幫忙

0

VBScript 匯入 csv 檔問題

小弟工作上需要透過VBScript(xxx.vbs)來匯入多個CSV檔,但是遇到下述幾個問題請教程式設計的高手幫忙

  1. 要怎樣循環將執行目錄下的多個CSV檔匯入到同一個Excel檔案內,然後用CSV檔名作為Excel檔案中的資料表名稱。
  2. 匯入的CSV檔有個麻煩的問題,裡面是使用"","","",""的方式區分欄位,但是其中有一個欄位內容資料筆數有多行(在Excel開啟時顯示該欄有兩行以上資料,用Notepad++開啟會看到該列資料分成三四行顯示)。
  3. VBScript有辦法匯入上述CSV資料的時候,過程使用陣列或變數的方式來進行嗎?例如讀取CSV檔案的資料,放到A陣列或ABC變數,再寫入EXCEL檔案中(因為寫入EXCEL檔案時順序可能會變成CAB)。

以上,請各位高手指導,謝謝。

ccutmis iT邦新手 1 級 ‧ 2017-07-17 14:21:09 檢舉
https://stackoverflow.com/questions/39478062/import-multiple-txt-csv-into-one-excel-sheet-but-each-file-in-next-column
謝謝您提供連結,但小弟看不太懂 ................. 所以才求助!!

1 個回答

1
xgtcarter
iT邦新手 5 級 ‧ 2017-07-18 13:14:24
最佳解答

關於多行資料可能要有實際的資料作測試才比較好修改程式去對應
其他的部分已經可以實現,程式是在Excel2013下測試完成的(2007測試也可以)
執行前請先確認VBS同目錄下的CSV目錄是否存在,並將要讀取的CSV檔放置在CSV目錄內

Option Explicit

Const ForReading = 1

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

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
            arrStr = Split(txtStream.ReadLine, ",")
            For x = 0 To UBound(arrStr)
                .Sheets(s).Cells(y, x + 1).Value = arrStr(x)
            Next
            y = y + 1
        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提供的程式,在分行的部分好像有一些問題。
不過也發現原本的CSV檔中,有空行跟不對稱的資料欄位
還在想辦法處理。

謝謝 xgtcarter 的指導。

xgtcarter iT邦新手 5 級 ‧ 2017-07-21 13:27:03 檢舉

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

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

xgtcarter iT邦新手 5 級 ‧ 2017-07-26 11:55:57 檢舉

已私訊我的E-Mail了

xgtcarter iT邦新手 5 級 ‧ 2017-07-28 14:42:45 檢舉

由於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欄位的順序,我可以透過那個變數(或陣列)來改變呢?謝謝您!!

xgtcarter iT邦新手 5 級 ‧ 2017-08-08 10:35:55 檢舉

輸出的欄位順序是按照讀入的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的錯誤

xgtcarter iT邦新手 5 級 ‧ 2017-11-17 13:03:10 檢舉

抱歉,因為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
xgtcarter iT邦新手 5 級 ‧ 2017-11-18 13:04:17 檢舉

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

xgtcarter iT邦新手 5 級 ‧ 2017-11-22 14:17:35 檢舉

我按照你給的範例csv測試是沒有問題,可能你測試的csv檔格式跟你給我的範例csv不一樣吧;你測試的csv檔一共幾個?太多個我不確定會不會造成跑太久而導致跑不完的假象,還有使用之前未更改的程式碼能順利跑完嗎?

抱歉,後來是小弟太心急了,以為程式運作時就會產生Excel檔案,後來才發現執行需要等待時間,待執行完畢後才會產生出Excel檔案。
目前運作都是正常的,衷心感謝您!!

我要發表回答

立即登入回答