0
好吧,这会很长。VB - 在同一个单元格内用excel导入CSV文件
我有一个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等。
你举的例子有引用文本中的多个'newline'令牌。如果那些确实不存在,那么根据你的Excel版本,我会建立一个数据连接,或者将文件复制到'.txt'文件;使用'Workbooks.OpenText'方法打开文件并指定分隔符;然后在完成处理并关闭文本文件时删除文本文件。 –
我想保留所有'newline'标记。这与''''相同,这只是一个测试用例。 – Cadeq
如果需要保留换行符,可以通过查询来完成。由于通过Excel(不使用VBA)导入它的方法适用于您,因此我建议您仅在此时记录一个宏,并将其用作导入文件的基础。比使用FileSystemObject重新创建轮子并使用字符串操作解析文件要容易得多。 –