Option
Explicit
Sub
textdateien_uebernehmen()
Dim
strZielDatei
As
String
Dim
lngLaufZahl
As
Long
Dim
strDateiNamen
As
Variant
Dim
trgWB
As
Excel.Workbook
Dim
tmpWB
As
Excel.Workbook
Dim
trgWBName
As
String
Dim
bslashPos
As
Integer
Dim
shName
As
String
On
Error
GoTo
Fehler
Application.ScreenUpdating =
False
Application.EnableEvents =
False
Application.DisplayAlerts =
False
strZielDatei = Application.GetOpenFilename(
"Excel-Arbeitsmappe (*.xls),*.xls"
, ,
"Zieldatei auswählen..."
, ,
False
)
Set
trgWB = Workbooks.Open(strZielDatei)
strDateiNamen = Application.GetOpenFilename(
"Text-Dateien(*.txt*),*.txt*"
, ,
"Zu importierende Textdateien auswählen..."
, ,
True
)
If
IsArray(strDateiNamen)
Then
For
lngLaufZahl = LBound(strDateiNamen)
To
UBound(strDateiNamen)
Set
tmpWB = Workbooks.Open(strDateiNamen(lngLaufZahl))
tmpWB.Sheets(1).UsedRange.Columns(
"A"
).
Select
Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=
True
For
bslashPos = Len(strDateiNamen(lngLaufZahl))
To
1
Step
-1
If
Mid(strDateiNamen(lngLaufZahl), bslashPos, 1) = "\"
Then
Exit
For
Next
bslashPos
shName = strDateiNamen(lngLaufZahl)
shName = Right(shName, Len(shName) - bslashPos)
shName = Left(shName, Len(shName) - 4)
If
Len(shName) > 31
Then
shName = Left(shName, 31)
tmpWB.Sheets(1).Name = shName
tmpWB.Sheets(shName).Range(
"A1"
).
Select
tmpWB.Sheets(1).Copy After:=trgWB.Sheets(trgWB.Sheets.Count)
trgWB.Save
tmpWB.Close
False
Set
tmpWB =
Nothing
Next
lngLaufZahl
Else
Set
tmpWB = Workbooks.Open(strDateiNamen)
tmpWB.Sheets(1).UsedRange.Columns(
"A"
).
Select
Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=
True
For
bslashPos = Len(strDateiNamen)
To
1
Step
-1
If
Mid(strDateiNamen, bslashPos, 1) = "\"
Then
Exit
For
Next
bslashPos
shName = strDateiNamen(lngLaufZahl)
shName = Right(shName, Len(shName) - bslashPos)
shName = Left(shName, Len(shName) - 4)
If
Len(shName) > 31
Then
shName = Left(shName, 31)
tmpWB.Sheets(1).Name = shName
tmpWB.Sheets(shName).Range(
"A1"
).
Select
tmpWB.Sheets(1).Copy After:=trgWB.Sheets(trgWB.Sheets.Count)
trgWB.Save
tmpWB.Close
False
Set
tmpWB =
Nothing
End
If
Set
trgWB =
Nothing
Application.ScreenUpdating =
True
Application.EnableEvents =
True
Application.DisplayAlerts =
True
Exit
Sub
Fehler:
MsgBox
"Fehlernummer: "
& Err.Number & Chr(10) _
&
"Fehlerbeschreibung: "
& Err.Description & Chr(10) _
&
"Verursacht durch: "
& Err.Source, vbInformation,
"Fehler..."
Err.Clear
Resume
Next
End
Sub