VB - 在excel中导入CSV，同一单元格中的结束行

Question

好的，这会很长。

我有一个我想在excel中导入的csv文件。

这是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的外观。

使用VB在excel上导入此CSV时（excel将导入大量csv文件），这就是它的外观。

这是我导入CSV的VB代码

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

我知道这段代码可以优化，但现在可以使用