Option
Explicit
Sub
textdateien_uebernehmen()
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
strDateiNamen = Application.GetOpenFilename(
"Text-Dateien(*.txt*),*.txt*"
, MultiSelect:=
True
)
If
IsArray(strDateiNamen)
Then
For
lngLaufZahl = LBound(strDateiNamen)
To
UBound(strDateiNamen)
If
lngLaufZahl = LBound(strDateiNamen)
Then
Set
trgWB = Workbooks.Open(Filename:=strDateiNamen(lngLaufZahl))
trgWB.Sheets(1).UsedRange.
Select
Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=
True
For
bslashPos = Len(strDateiNamen(lngLaufZahl))
To
1
If
Mid(strDateiNamen(lngLaufZahl), bslashPos, 1) = "\"
Then
Exit
For
Next
bslashPos
shName = strDateiNamen(lngLaufZahl)
shName = Right(shName, bslashPos - 1)
shName = Left(shName, Len(shName) - 4)
trgWB.Sheets(1).Name = shName
trgWBName = Application.GetSaveAsFilename(,
"Excel-Arbeitsmappe (*.xls),*.xls"
)
trgWB.SaveAs trgWBName, xlWorkbookNormal
Else
Set
tmpWB = Workbooks.Open(Filename:=strDateiNamen(lngLaufZahl))
tmpWB.Sheets(1).UsedRange.
Select
Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=
True
For
bslashPos = Len(strDateiNamen(lngLaufZahl))
To
1
If
Mid(strDateiNamen(lngLaufZahl), bslashPos, 1) = "\"
Then
Exit
For
Next
bslashPos
shName = strDateiNamen(lngLaufZahl)
shName = Right(shName, bslashPos - 1)
shName = Left(shName, Len(shName) - 4)
tmpWB.Sheets(1).Name = shName
tmpWB.Sheets(1).Copy After:=Workbooks(trgWBName).Sheets(trgWB.Sheets.Count)
trgWB.Save
tmpWB.Close
False
Set
tmpWB =
Nothing
End
If
Next
lngLaufZahl
Else
Set
trgWB = Workbooks.Open(Filename:=strDateiNamen)
trgWB.Sheets(1).UsedRange.
Select
Selection.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, semicolon:=
True
For
bslashPos = Len(strDateiNamen)
To
1
If
Mid(strDateiNamen, bslashPos, 1) = "\"
Then
Exit
For
Next
bslashPos
shName = strDateiNamen
shName = Right(shName, bslashPos - 1)
shName = Left(shName, Len(shName) - 4)
trgWB.Sheets(1).Name = shName
trgWBName = Application.GetSaveAsFilename(,
"Excel-Arbeitsmappe (*.xls),*.xls"
)
trgWB.SaveAs trgWBName, xlWorkbookNormal
End
If
Set
trgWB =
Nothing
End
Sub