Sub Excel_CSVImportZahlenAusDatei()
'Import aus einer CSV-Datei, in der Zahlen durch Semikolon getrennt sind
'1;2;3;4;5;6;7;8;9;10;11;12;13;14;15;16,6;17;18;19;20;21;22;23;24;25;26;27;28;29;30;31;32;33;34;35;36;37;38;39;40;41;42;43;44;
'
'Die Csv-Datei muß im Verzeichnis des Excel-Mappe liegen
'Die Zeilen in der CSV-Datei werden auf dem Blatt->Import' spaltenweise ausgegeben
'(Anfang bei A1)
-><<< A N P A S S E N >>>
Const c_CSV_DATEINAME = MyZahlenDaten.csv
Const c_BLATT_ZIEL = Import
-><<< A N P A S S E N E N D E >>>
Dim wb As Workbook, wsz As Worksheet
Dim wbcsv As Workbook, wscsv As Worksheet
Dim MyPath As String, Dateiname_Full As String
Dim l_LetzteZeile As Long, l_LetzteSpalte As Long, dWert As Double
Dim z As Long, sp As Long
->Aktive Arbeitsmappe setzen
Set wb = ActiveWorkbook
->Pfad zur aktiven Arbeitsmappe
MyPath = wb.Path
->vollständiger Pfad CSV-Datei
Dateiname_Full = MyPath & Application.PathSeparator & c_CSV_DATEINAME
->ZielBlatt setzen
On Error Resume Next
Set wsz = wb.Worksheets(c_BLATT_ZIEL)
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
If wsz Is Nothing Then
MsgBox Zielblatt-> & c_BLATT_ZIEL &-> nicht vorhanden.
GoTo AUFRAEUMEN
End If
->CSV-Datei nicht vorhanden ?
If Dir(Dateiname_Full) = Then
MsgBox CSV-Datei-> & Dateiname_Full &-> nicht vorhanden.
GoTo AUFRAEUMEN
End If
->CSV-Datei öffen, Trennzeichen->;'
On Error Resume Next
Workbooks.Open _
FileName:=MyPath & Application.PathSeparator & c_CSV_DATEINAME, _
Delimiter:=;
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
Set wbcsv = ActiveWorkbook
Set wscsv = ActiveSheet
->Prüfen, ob beim Öffnen etwas schiefgegangen ist
If wbcsv.Name = wb.Name Then
MsgBox CSV-Datei-> & Dateiname_Full &-> konnte nicht geöffnet werden.
GoTo AUFRAEUMEN
End If
->Benutzen Bereich feststellen
l_LetzteZeile = wscsv.UsedRange.Rows.Count
l_LetzteSpalte = wscsv.UsedRange.Columns.Count
->Werte der Zeilen in Spalten des Zielblattes übertragen
On Error Resume Next
For z = 1 To l_LetzteZeile
For sp = 1 To l_LetzteSpalte
dWert = CDbl(wscsv.Cells(z, sp).Value)
If Err.Number <> 0 Then
Err.Clear
wsz.Cells(sp, z).Value = Fehler
Else
wsz.Cells(sp, z).Value = dWert
End If
Next
Next
->CSV-Datei schliessen
wbcsv.Close Savechanges:=False
AUFRAEUMEN:
Set wb = Nothing: Set wsz = Nothing
Set wbcsv = Nothing: Set wscsv = Nothing
End Sub
