Warum, Leute, könnt ihr nie richtig beschreiben was Ihr wirklich wollt? Fast jedesmal muß man Code nachbessern oder komplett umarbeiten, weil ihr Euer Problem falsch oder unvollständig beschreibt! Das verursacht unnötige Arbeits und vor allem Ärger: Schließlich habe ich anderes zu tun als x-mal Code anzupassen, weil Ihr Eure Probleme nicht so darlegt wie sie wirklich sind! Bitte in Zukunft wirklich so beschreiben, wie Ihr die Lösung wirklich haben wollt!
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
'Ereignisse abschalten
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Zieldatei auswählen und öffnen
strZielDatei = Application.GetOpenFilename("Excel-Arbeitsmappe (*.xls),*.xls", , "Zieldatei auswählen...", , False)
Set trgWB = Workbooks.Open(strZielDatei)
'Zu importierende Textdateien auswählen
strDateiNamen = Application.GetOpenFilename("Text-Dateien(*.txt*),*.txt*", , "Zu importierende Textdateien auswählen...", , True)
'Mehrere Dateien ausgewählt
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
'In Zieldatei kopieren
tmpWB.Sheets(1).Copy After:=trgWB.Sheets(trgWB.Sheets.Count)
trgWB.Save
'Temporäre Datei ohne speichern schließen, Verweis freigeben
tmpWB.Close False
Set tmpWB = Nothing
Next lngLaufZahl
'Nur eine Datei ausgwählt
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
'Verweis freigeben
Set trgWB = Nothing
'Ereignisse einschalten
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
Severus
|