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
On Error GoTo Fehler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
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.Columns("A").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 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)
trgWB.Sheets(1).Name = shName
trgWB.Sheets(shName).Range("A1").Select
trgWBName = Application.GetSaveAsFilename(, "Excel-Arbeitsmappe (*.xls),*.xls")
trgWB.SaveAs trgWBName, xlWorkbookNormal
Else
Set tmpWB = Workbooks.Open(Filename:=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
End If
Next lngLaufZahl
Else
Set trgWB = Workbooks.Open(Filename:=strDateiNamen)
trgWB.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
shName = Right(shName, Len(shName) - bslashPos)
shName = Left(shName, Len(shName) - 4)
If Len(shName) > 31 Then shName = Left(shName, 31)
trgWB.Sheets(1).Name = shName
trgWB.Sheets(shName).Range("A1").Select
trgWBName = Application.GetSaveAsFilename(, "Excel-Arbeitsmappe (*.xls),*.xls")
trgWB.SaveAs trgWBName, xlWorkbookNormal
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
Versuchs mal damit. Severus
|