Hallo,
der Code sieht so aus:
Option Explicit
Sub ImportCSV()
Dim shtImport As Worksheet
Dim strDelChar As String
Dim strFileName As String
Dim lRow As Long
Dim lCol As Long
Dim strText As String
Dim strChar As String * 1
Dim vntData As Variant
Dim lCharCount As Long
Const Zahl1 As Long = 1
Dim ZeileMax As Long
Dim ZeileMax1 As Long
Dim Row As Long
Dim rootDir As String
'Leere Zeilen entfernen
With Import
ZeileMax1 = .UsedRange.Rows.Count
For Row = ZeileMax1 To 4 Step -1
If Application.WorksheetFunction.CountA(.Rows(Row)) = 0 Then
.Rows(Row).Delete
End If
Next Row
End With
'Zeile für Import ermitteln
ZeileMax = Import.UsedRange.Rows.Count
ZeileMax = CDbl(Zahl1) + CDbl(ZeileMax)
'Change the name "Import" according to your sheet name.
Set shtImport = Sheets("Import")
'Change the delimited character "," according to your own needs.
'NOTE: Due to the code structure only one character is accepted
' for delimited character (example "%", "-", "|" etc.).
strDelChar = ";"
'Show the file dialog and select a CSV file.
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Select a CSV file!"
.Filters.Clear
.Filters.Add "Semicolon Separated Values", "*.csv"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You did't select a CSV file!", vbExclamation, "Canceled"
Exit Sub
Else
strFileName = .SelectedItems(1)
End If
End With
Application.ScreenUpdating = False
'Check if the selected file is CSV file.
If UCase(Right(strFileName, 3)) <> "CSV" Then
MsgBox "The file you select is not a CSV file!", vbCritical, "Error!"
Exit Sub
End If
'Open the CSV file.
On Error Resume Next
Open strFileName For Input As #1
'Check if the file was opened.
If Err <> 0 Then
MsgBox "File not found: " & strFileName, vbCritical, "Error"
Exit Sub
End If
On Error GoTo 0
'Initializing the variables.
lRow = 0
lCol = 0
strText = ""
'Activate the A1 cell on Import sheet.
shtImport.Activate
Range("A" & ZeileMax).Activate
'Loop through all lines of CSV file and import the data values to the active sheet.
Do Until EOF(1)
'Pass the line data to a variable.
Line Input #1, vntData
'Loop through all characters of the variable.
For lCharCount = 1 To Len(vntData)
'Examine each character separately.
strChar = Mid(vntData, lCharCount, 1)
'If reach the delimited character write the value to a cell.
If strChar = strDelChar Then
ActiveCell.Offset(lRow, lCol) = strText
lCol = lCol + 1
strText = ""
'If reache the end of the line write the (last) value to a cell and
'then reset the strText variable.
ElseIf lCharCount = Len(vntData) Then
If strChar <> Chr(34) Then strText = strText & strChar
ActiveCell.Offset(lRow, lCol) = strText
strText = ""
'In any other case concatenate the character with the strText variable.
ElseIf strChar <> Chr(34) Then
strText = strText & strChar
End If
Next lCharCount
'Reset the variables for the next line of data.
lCol = 0
lRow = lRow + 1
Loop
'Close the CSV file.
Close #1
' Duplikate entfernen
Range("A3:E320000").Select
ActiveSheet.Range("$A$3:$E$320000").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), _
Header:=xlYes
' Leere Zelen loeschen
With Import
ZeileMax1 = .UsedRange.Rows.Count
For Row = ZeileMax1 To 4 Step -1
If Application.WorksheetFunction.CountA(.Rows(Row)) = 0 Then
.Rows(Row).Delete
End If
Next Row
End With
'Dim arrIst, arrSoll, x
''
''Split-Funktion
''Gibt ein nullbasiertes, eindimensionales Datenfeld zurück,
''das eine festgelegte Anzahl an untergeordneten Zeichenfolgen enthält.
''Split(Zeichenfolge, Trennzeichen)
''
''einen individuellen Vergleich basteln
''denn nicht jede Datenquelle benutzt die gleichen Sonderzeichen
''
'arrIst = Split("„,”,,Ž,™,š,á", ",")
'arrSoll = Split("ä,ö,ü,Ä,Ö,Ü,ß", ",")
''
'For x = 0 To UBound(arrIst)
' Cells.Replace What:=arrIst(x), _
' Replacement:=arrSoll(x), _
' LookAt:=xlPart, _
' SearchOrder:=xlByRows, _
' MatchCase:=True, _
' SearchFormat:=False, _
' ReplaceFormat:=False
'Next x
' ScreenUpdate aktivieren
Application.ScreenUpdating = True
' Inform the user about the process.
MsgBox "The file " & strFileName & " was successfully imported on sheet " & _
shtImport.Name & "!", vbInformation, "Done"
End Sub
|