VB - Import CSV in excel with end line in same cell - excel

Question

Ok, this gonna be long.
I have a csv file that I want to import in a excel.
This is the CSV file.
"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"
This is how looks on excel.
When this CSV is imported on excel using VB (the excel will import a lot of csv files), this is how it looks.
This is my VB code to import 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
I want that in the excel to look like when you open the csv in excel.

Answer 1

This was my solution.
First I added two new functions.
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
Also I modified 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
I know that this code can optimized but for now It works