Option
Compare Database
Option
Explicit
Public
Sub
testImport()
Call
importCSV(
"C:\Users\userXY\Desktop\Beispiel.csv"
)
End
Sub
Public
Sub
importCSV(
ByVal
path
As
String
)
Dim
fso
As
New
FileSystemObject
If
Not
fso.FileExists(path)
Then
MsgBox
"Datei existiert nicht."
, vbInformation
GoTo
cleanUp
End
If
Dim
db
As
DAO.Database
Dim
ts
As
TextStream
Dim
arr()
As
String
, arrP()
As
String
Dim
sTablename
As
String
Dim
l
As
Long
, m
As
Long
Dim
sSqlV
As
String
, sSql
As
String
sTablename = fso.GetBaseName(path)
Set
db = CurrentDb
Call
createTable(db, sTablename)
Set
ts = fso.OpenTextFile(path, ForReading,
False
)
sSqlV =
"INSERT INTO "
& sTablename &
"(Gruppennummer, Programmnummer, Programmname) VALUES ('%GNUMMER%', '%PNUMMER%', '%PNAME%');"
l = 1
Do
While
Not
ts.AtEndOfStream
arrP() = arr()
arr() = Split(ts.ReadLine,
";"
)
If
IsNumeric(arr(0))
Then
For
l = 1
To
UBound(arr())
sSql = Replace(sSqlV,
"%GNUMMER%"
, arr(0))
sSql = Replace(sSql,
"%PNUMMER%"
, arr(l))
sSql = Replace(sSql,
"%PNAME%"
, arrP(l))
db.Execute sSql
m = m + 1
Next
l
End
If
Loop
MsgBox
"Es wurden "
& m &
" Einträge in die Tabelle '"
& sTablename &
"' eingefügt."
, vbInformation
cleanUp:
If
Not
ts
Is
Nothing
Then
ts.Close
Set
ts =
Nothing
End
If
If
Not
db
Is
Nothing
Then
Set
db =
Nothing
If
Not
fso
Is
Nothing
Then
Set
fso =
Nothing
End
Sub
Private
Sub
createTable(
ByRef
db
As
DAO.Database,
ByVal
tablename
As
String
)
On
Error
Resume
Next
db.TableDefs.Delete tablename
On
Error
GoTo
0
Dim
tdf
As
TableDef
Dim
fld
As
Field
Dim
v
As
Variant
Dim
colFields
As
New
Collection
With
colFields
.Add
"Gruppennummer"
.Add
"Programmnummer"
.Add
"Programmname"
End
With
Set
tdf = db.CreateTableDef(tablename)
For
Each
v
In
colFields
Set
fld = tdf.CreateField(v, dbText, 255)
With
tdf.Fields
.Append fld
.Refresh
End
With
Set
fld =
Nothing
Next
v
With
db.TableDefs
.Append tdf
.Refresh
End
With
Set
tdf =
Nothing
Set
colFields =
Nothing
End
Sub
Viele Grüße