AW: Ergänzung
11.02.2005 06:05:11
Björn B.
Hallo Uwe,
das Problem entsteht dadurch, dass du beim Export nicht mehr den Blattnamen sondern den Codenamen abspeicherst. Deshalb ist die Anweisung bei Import fehlerhaft, da es ja sheets(Blattname) und nicht sheets(codename) heißt.
Beide Varianten, Code- und Blattname, haben ihre Vor- und Nachteile. Wenn du mit dem Codenamen arbeitest, kommst du immer wieder auf das selbe Tabellenblatt zurück, was nur solange klappt, bis einer das mal kopiert und das Original löscht (das gleiche ist ja nicht das selbe!). Auf der anderen Seite ist das Risiko beim Blattnamen, dass einer das Tabellenblatt umbenennt. Denkbar wäre als noch sicherere Variante sowohl Codenamen als auch Blattnamen beim Export der Datei voranzustellen und zunächst nach dem Codenamen und danach nach dem Blattnamen zu suchen und nur wenn gar nichts passt abzubrechen.
Wenn du das im Export nicht wieder ändern willst, dann musst du die nachfolgende Import-Prozedur verwenden.
Sub importData()
Dim wks As Worksheet
Dim sFile As String, tmp As String
Dim arr As Variant
Dim n As Long, m As Integer, i As Integer
Application.ScreenUpdating = False
Application.Run ("Blattschutz_aufheben")
Application.Run ("alle_Tabellenblätter_einblenden")
sFile = Application.GetOpenFilename("Text Dateien (*.txt), *.txt")
If sFile = "Falsch" Then Exit Sub
On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Open sFile For Input As #1
Do While Not EOF(1)
Input #1, tmp
arr = Split(tmp, ";")
For Each wks In Sheets
If wks.CodeName <> arr(0) Then
Set wks = Nothing
Else
Exit For
End If
Next
If wks Is Nothing Then
Close #1
MsgBox "Das Tabellenblatt zum Einfügen der Daten wurde gelöscht!"
Exit Sub
End If
For n = 1 To 157
For m = 1 To 12
i = i + 1
wks.Cells(n, m) = arr(i)
Next
Next
Loop
Close #1
ERRORHANDLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Application.Run ("Formeln_einfügen")
Application.Run ("inaktive_Blätter_ausblenden")
Application.Run ("Zusammenfassung_ausblenden")
Application.Run ("Blattschutz")
End Sub
Wenn du die Variante mit Code- und Blattnamen ausprobieren willst, dann versuche es mal mit folgenden Ex- und Import-Prozeduren:
Option Explicit
Sub exportData()
Dim wks As Worksheet
Dim sFile As String, tmp As String
Dim arr() As Variant
Dim n As Long, m As Integer, j As Long
Application.ScreenUpdating = False
sFile = Application.GetSaveAsFilename(InitialFilename:=".txt", _
FileFilter:="Text Dateien (*.txt), *.txt")
If sFile = "Falsch" Then Exit Sub
On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Open sFile For Output As #1
For Each wks In ThisWorkbook.Worksheets
If wks.CodeName <> "Tabelle1" And wks.CodeName <> "Tabelle4" And wks.CodeName <> "Tabelle2" Then
'hier die Namen der Tabellen die NICHT exportiert werden sollen angeben!
arr = wks.Range("A1:L157").Value
arr = Application.Transpose(arr)
For m = 1 To UBound(arr, 2)
For n = 1 To UBound(arr, 1)
'nachfolgend wird das Komma bei Dezimalzahlen in einen Punkt verwandelt, um beim
'Import keine fehlerhafte Anzeige zu erhalten
If IsNumeric(arr(n, m)) Then
For j = 1 To Len(arr(n, m))
If Mid(arr(n, m), j, 1) = "," Then
arr(n, m) = Left(arr(n, m), j - 1) & "." & Right(arr(n, m), Len(arr(n, m)) - j)
Exit For
End If
Next j
End If
tmp = tmp & ";" & arr(n, m)
Next
Next
Write #1, wks.CodeName & ";" & wks.Name & tmp
wks.Range("A1:L157").ClearContents
End If
Next
Close #1
MsgBox "Die Daten wurden erfolgreich Exportiert!"
ERRORHANDLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
Application.Run ("Formeln_einfügen")
Application.Run ("Name_zurücksetzen_1")
Application.Run ("Name_zurücksetzen_2")
Application.Run ("Name_zurücksetzen_3")
Application.Run ("Name_zurücksetzen_4")
Application.Run ("Name_zurücksetzen_5")
Application.Run ("Name_zurücksetzen_6")
Application.Run ("Name_zurücksetzen_7")
Application.Run ("Name_zurücksetzen_8")
Application.Run ("Name_zurücksetzen_9")
Application.Run ("Name_zurücksetzen_10")
Application.Run ("Zusammenfassung_ausblenden")
Application.Run ("Blattschutz")
Application.Run ("inaktive_Blätter_ausblenden")
End Sub
Sub importData()
Dim wks As Worksheet
Dim sFile As String, tmp As String
Dim arr As Variant
Dim n As Long, m As Integer, i As Integer
Application.ScreenUpdating = False
Application.Run ("Blattschutz_aufheben")
Application.Run ("alle_Tabellenblätter_einblenden")
sFile = Application.GetOpenFilename("Text Dateien (*.txt), *.txt")
If sFile = "Falsch" Then Exit Sub
On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
Open sFile For Input As #1
Do While Not EOF(1)
Input #1, tmp
arr = Split(tmp, ";")
For Each wks In Sheets
If wks.CodeName <> arr(0) Then
Set wks = Nothing
Else
Exit For
End If
Next
If wks Is Nothing Then
For Each wks In Sheets
If wks.Name <> arr(1) Then
Set wks = Nothing
Else
Exit For
End If
Next
End If
If wks Is Nothing Then
Close #1
MsgBox "Das Tabellenblatt zum Einfügen der Daten wurde gelöscht!"
Exit Sub
End If
i = 1 'Zähler muss um eins höher gesetzt werden, da in arr(0) der codename
'und in arr(1) der Blattname steht.
For n = 1 To 157
For m = 1 To 12
i = i + 1
wks.Cells(n, m) = arr(i)
Next
Next
Loop
Close #1
ERRORHANDLER:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Application.Run ("Formeln_einfügen")
Application.Run ("inaktive_Blätter_ausblenden")
Application.Run ("Zusammenfassung_ausblenden")
Application.Run ("Blattschutz")
End Sub
Falls Du noch Probleme hast, kann ich dir leider erst ab dem 19.02. wieder helfen, da ich gleich in den Urlaub fahre. Entweder musst du dich dann gedulden oder dich wieder ans Forum wenden.
Falls es dann noch von Belang ist, habe ich kein Problem damit dir eine E-Mail zu schicken, nur posten möchte ich die Adresse nicht.
Lass von dir hören, ob's klappt.
Viel Erfolg!
Gruß
Björn