Könnet etwa so aussehen:
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
'Hier das Trennzeichen ggf. ändern und das Format der einzelnen Spalten als Array definieren
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
Severus
|