Public
Sub
import()
Dim
objStream, strData
Dim
Spalte
As
Long
Dim
strPfad
As
String
Dim
strDatei
As
String
Dim
strOrdner
As
String
Dim
strEndung
As
String
Dim
Auftragnummer
As
String
Dim
intr1
As
Integer
, intr2
As
Integer
, Suchspalte
As
Integer
Spalte = 2
strPfad = Range(
"J1"
)
strEndung = Range(
"J2"
)
strOrdner =
"\" & Range("
J3
") & "
\"
If
Dir(strPfad & strOrdner, vbDirectory) =
""
Then
MkDir (strPfad & strOrdner)
End
If
Suchspalte = 4
For
intr1 = 1
To
Cells(Rows.Count, 4).
End
(xlUp).Row
For
intr2 = intr1 + 1
To
Cells(Rows.Count, 4).
End
(xlUp).Row
If
Cells(intr1, Suchspalte) = Cells(intr2, Suchspalte)
Then
MsgBox Cells(intr1, Suchspalte).Value &
" ist doppelt vorhanden (Zeile"
& intr1 &
" und "
& intr2 &
" Es werden keine Dateien erzeugt, da diese sonst überschrieben werden! Bitte Doppelte Einträge korrigieren!"
Exit
Sub
End
If
Next
intr2
Next
intr1
Do
While
Cells(Spalte, 1).Value <>
""
strDatei = Range(
"D"
& Spalte)
Set
objStream = CreateObject(
"ADODB.Stream"
)
objStream.Charset =
"utf-8"
objStream.Open
objStream.LoadFromFile (
"E:\Eigene Dateien\muster.GEO"
)
strData = objStream.ReadText()
strData = Replace(strData,
"laenge"
, Range(
"A"
& Spalte))
strData = Replace(strData,
"breite"
, Range(
"B"
& Spalte))
strData = Replace(strData,
"anzahll"
, Range(
"E"
& Spalte))
strData = Replace(strData,
"lochx"
, Range(
"F"
& Spalte))
strData = Replace(strData,
"lochy"
, Range(
"G"
& Spalte))
strData = Replace(strData,
"mmquad"
, Range(
"C"
& Spalte))
Set
objStream = CreateObject(
"ADODB.Stream"
)
objStream.Charset =
"utf-8"
objStream.Open
objStream.WriteText strData
objStream.SaveToFile strPfad & strOrdner & strDatei & strEndung, 2
objStream.Close
Spalte = Spalte + 1
Loop
End
Sub