VB - 在同一個單元格內用excel導入CSV文件

Question

好吧，這會很長。

我有一個csv文件，我想在Excel中導入。

這是CSV文件。

"NIP";"Date start";"Date end";"Reason";"coment" 
"1";"06/06/17 09:55";"";"test";"asdasd ad ,a dasds asd;asdfasfasdfad , 
asdfasdfda a 
asffasd , asdf asf asfad; asfasfasfa ;sadfdasds 
,adasdsa ,asdassda,adadasddasd, asd asdasdad 
;;;;adasdasdsa ,,,,sfdafas" 

這是如何看待excel。

當這個CSV是在Excel中使用VB進口（在Excel將導入大量的CSV文件），這是它的外觀。

這是我的VB代碼導入CSV

Option Explicit 

Sub ImportFiles() 
Dim sPath As String 

sPath = ThisWorkbook.Path & "\data\1.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "1" 

sPath = ThisWorkbook.Path & "\data\2.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "2" 

sPath = ThisWorkbook.Path & "\data\3.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "3" 

sPath = ThisWorkbook.Path & "\data\4.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "4" 

sPath = ThisWorkbook.Path & "\data\5.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "5" 

sPath = ThisWorkbook.Path & "\data\6.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "6" 

sPath = ThisWorkbook.Path & "\data\7.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "7" 

sPath = ThisWorkbook.Path & "\data\8.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "8" 

sPath = ThisWorkbook.Path & "\data\9.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "9" 

sPath = ThisWorkbook.Path & "\data\10.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "10" 

sPath = ThisWorkbook.Path & "\data\11.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "11" 

sPath = ThisWorkbook.Path & "\data\12.csv" 
copyDataFromCsvFileToSheet sPath, ";", "12" 

sPath = ThisWorkbook.Path & "\data\13.csv" 
'copyDataFromCsvFileToSheet sPath, ";", "13" 

Dim aux As String 
aux = FindReplaceAll() 

End Sub 

Private Sub copyDataFromCsvFileToSheet(parFileName As String, _ 
parDelimiter As String, parSheetName As String) 

    Dim Data As Variant 

    Data = getDataFromFile(parFileName, parDelimiter) 

If Not isArrayEmpty(Data) Then 
    If SheetExists(parSheetName) Then 
    With Sheets(parSheetName) 
     .Range("A1:OO2000").ClearContents 
     .Cells(1, 1).Resize(UBound(Data, 1), UBound(Data, 2)) = Data 
    End With 
    Else 
    Dim warning 
    warning = MsgBox("no existing sheet'" & parSheetName, vbOKOnly, "Warning") 
    End If 
End If 
End Sub 

Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean 
Dim sht As Worksheet 

If wb Is Nothing Then Set wb = ThisWorkbook 
On Error Resume Next 
Set sht = wb.Sheets(shtName) 
On Error GoTo 0 
SheetExists = Not sht Is Nothing 
End Function 

Function FindReplaceAll() 

Dim sht As Worksheet 
Dim fnd As Variant 
Dim rplc As Variant 

For Each sht In ActiveWorkbook.Worksheets 
    sht.Cells.Replace what:=Chr(34), Replacement:="", _ 
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ 
    SearchFormat:=False, ReplaceFormat:=False 
Next sht 

End Function 



Public Function isArrayEmpty(parArray As Variant) As Boolean 

If IsArray(parArray) = False Then isArrayEmpty = True 
On Error Resume Next 
If UBound(parArray) < LBound(parArray) Then 
    isArrayEmpty = True 
    Exit Function 
    Else 
    isArrayEmpty = False 
End If 

End Function 

Private Function getDataFromFile(parFileName As String, _ 
parDelimiter As String, _ 
Optional parExcludeCharacter As String = "") As Variant 

Dim locLinesList() As Variant 
Dim locData As Variant 
Dim i As Long 
Dim j As Long 
Dim lim As Long 
Dim locNumRows As Long 
Dim locNumCols As Long 
Dim fso As Variant 
Dim ts As Variant 
Const REDIM_STEP = 10000 

Set fso = CreateObject("Scripting.FileSystemObject") 

On Error GoTo error_open_file 

Set ts = fso.OpenTextFile(parFileName) 
On Error GoTo unhandled_error 

ReDim locLinesList(1 To 1) As Variant 
i = 0 
Do While Not ts.AtEndOfStream 
    Dim aux As String 
    aux = ts.ReadLine 
    If i Mod REDIM_STEP = 0 Then 
    ReDim Preserve locLinesList _ 
    (1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant 
    lim = UBound(Split(aux, parDelimiter)) + 1 
    End If 
    locLinesList(i + 1) = Split(aux, """+parDelimiter+""") 
    j = UBound(locLinesList(i + 1), 1) 

    If locNumCols < j Then locNumCols = j 
    i = i + 1 
Loop 

ts.Close 
locNumRows = i 

If locNumRows = 0 Then Exit Function 

ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant 

If parExcludeCharacter <> "" Then 
    For i = 1 To locNumRows 
    For j = 0 To UBound(locLinesList(i), 1) 
     If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then 
     If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then 
     locLinesList(i)(j) = _ 
     Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2) 
    Else 
     locLinesList(i)(j) = _ 
     Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1) 
    End If 
    ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then 
    locLinesList(i)(j) = _ 
    Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1) 
    End If 
    locData(i, j + 1) = locLinesList(i)(j) 
    Next j 
    Next i 
Else 
    For i = 1 To locNumRows 
    For j = 0 To UBound(locLinesList(i), 1) 
    locData(i, j + 1) = locLinesList(i)(j) 
    Next j 
    Next i 
End If 

getDataFromFile = locData 

Exit Function 

error_open_file: 
unhandled_error: 

End Function 

我想，在Excel中，尋找當你在Excel中打開CSV等。

Answer 1

這是我的解決方案。

首先我添加了兩個新功能。

Public Function mergeArrays(arr1 As Variant, arr2 As Variant) As Variant 
Dim i As Integer 
Dim sizeArr1 As Integer 
Dim arr3() As String 
ReDim arr3(UBound(arr1) + UBound(arr2) + 1) 

sizeArr1 = UBound(arr1) + 1 
For i = 0 To UBound(arr1) 
    arr3(i) = arr1(i) 
Next i 
For i = 0 To UBound(arr2) 
    arr3(i + sizeArr1) = arr2(i) 
Next i 
mergeArrays = arr3 

End Function 


Public Function DeleteElementAt(inArray As Variant) As Variant 
    Dim index As Integer 
    Dim aux() As String 
    ReDim aux(UBound(inArray) - 1) 

    For index = 1 To UBound(inArray) 
     aux(index - 1) = inArray(index) 
    Next index 


    DeleteElementAt = aux 
End Function 

而且我修改getDataFromFile

Private Function getDataFromFile(parFileName As String, _ 
parDelimiter As String, _ 
Optional parExcludeCharacter As String = "") As Variant 

Dim locLinesList() As Variant 
Dim locData As Variant 
Dim linea() As String 
Dim i As Long 
Dim j As Long 
Dim lim As Long 
Dim locNumRows As Long 
Dim locNumCols As Long 
Dim fso As Variant 
Dim ts As Variant 
Const REDIM_STEP = 10000 

Set fso = CreateObject("Scripting.FileSystemObject") 

On Error GoTo error_open_file 

Set ts = fso.OpenTextFile(parFileName) 
On Error GoTo unhandled_error 

ReDim locLinesList(1 To 1) As Variant 
i = 0 
Do While Not ts.AtEndOfStream 
    Dim aux As String 
    aux = ts.ReadLine 
    aux = Replace(aux, Chr(34) & ";" & Chr(34), Chr(34) & "#@#" & Chr(34)) 
    linea = Split(aux, "#@#") 
    If i Mod REDIM_STEP = 0 Then 
    ReDim Preserve locLinesList _ 
    (1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant 
    lim = UBound(linea) + 1 
    locNumCols = lim 
    locLinesList(i + 1) = linea 
    i = i + 1 
    Else 
    locLinesList(i + 1) = linea 


    If UBound(locLinesList(i)) + 1 < lim Then 
     locLinesList(i)(UBound(locLinesList(i))) = locLinesList(i)    
    (UBound(locLinesList(i))) & vbCrLf & linea(0) 
    linea = DeleteElementAt(linea) 
    locLinesList(i) = mergeArrays(locLinesList(i), linea) 
Else 
If UBound(linea) + 1 = 1 Then   
    locLinesList(i)(UBound(locLinesList(i))) = locLinesList(i)      
(UBound(locLinesList(i))) & vbCrLf & linea(0) 
Else 
'Linea es un salto de linea a secas 
If UBound(linea) = -1 Then 
    locLinesList(i)(UBound(locLinesList(i))) = locLinesList(i)  
(UBound(locLinesList(i))) & vbCrLf 
    Else 
     i = i + 1 
    End If 
    End If 


    End If 
    End If 
Loop 

Dim endVector() As Variant 
ReDim endVector(i) 
Dim index As Integer 

For index = 0 To i - 1 
    endVector(index) = locLinesList(index + 1) 
Next index 



ts.Close 
locNumRows = i 

If locNumRows = 0 Then Exit Function 

ReDim locData(1 To locNumRows, 1 To locNumCols) As Variant 

If parExcludeCharacter <> "" Then 
    For i = 1 To locNumRows 
    For j = 0 To UBound(endVector(i), 1) 
     If Left(endVector(i)(j), 1) = parExcludeCharacter Then 
     If Right(endVector(i)(j), 1) = parExcludeCharacter Then 
      endVector(i)(j) = _ 
      Mid(endVector(i)(j), 2, Len(endVector(i)(j)) - 2) 
     Else 
      endVector(i)(j) = _ 
      Right(endVector(i)(j), Len(endVector(i)(j)) - 1) 
     End If 
     ElseIf Right(endVector(i)(j), 1) = parExcludeCharacter Then 
     endVector(i)(j) = _ 
     Left(endVector(i)(j), Len(endVector(i)(j)) - 1) 
     End If 
     locData(i, j + 1) = endVector(i)(j) 
    Next j 
    Next i 
Else 
    For i = 0 To locNumRows - 1 
    For j = 0 To UBound(endVector(i), 1) 
     locData(i + 1, j + 1) = endVector(i)(j) 
    Next j 
    Next i 
End If 

getDataFromFile = locData 

Exit Function 

我知道，這個代碼可以優化，但現在它的工作原理