AW: Tabelleblatt kopieren hinterinander mit name
03.02.2008 23:39:00
fcs
Hallo Karel,
passe die Fehlerbehandlung etwas an. Statt "Goto" muss "Resume" zum Rücksprung in das Programm verwendet werden.
Die Input-Box zur Anpassung des Blattnamens wird dann wiederholt angezeig, bis der Name geändert wird oder Abbrechen gewählt wird. Resume bewikt, dass die Fehlerüberwachung zurückgesetzt wird.
Fehlerbehandlung:
MsgBox "Fehler Nummer " & Err.Number & " ist aufgetreten!" & vbLf & _
Err.Description
Select Case Fehler
Case 1
Case 2
Blattname = InputBox("Der Blattname mit der Lieferantennummer existiert bereits!" _
& vbLf & "Bitte den Blattnamen anpassen." & vbLf _
& "Bei Abbrechen wird das kopierte Blatt wieder gelöscht", _
"Lieferantenblatt kopieren", "Lieferant" _
& ws1.Range("D2").Text) ' ### ggf. anpassen
If Blattname "" Then
Resume BlattnameFestlegen
Else
Application.DisplayAlerts = False
wsZiel.Delete
Application.DisplayAlerts = True
Resume DateiSpeichern
End If
Case 3
Case 4
MsgBox "Die Textfelder zum Kopieren des Blattes konnten nicht gefunden/gelöscht werden!"
Case 5
Case Else
End Select
Ende:
Set wbZiel = Nothing: Set ws1 = Nothing: Set wsZiel = Nothing
End Sub
Die Syntax für die Zuweisung eines Namens zu einem Zellbereich sieht ein wenig anders aus; Eigenschaft .ReferTo muss gesetzt werden. Hier dann der komplette Code, um das Blatt in der Datei C:\Etikett\Etikett.xls anzufügen.
Gruß
Franz
Sub Copy_to_Etikett()
Dim ws1 As Worksheet, wsZiel As Worksheet, wbZiel As Workbook
Dim Pfad As String, Dateiname As String, Blattname As String
Dim Fehler As Integer
Set ws1 = Worksheets("Lieferant")
Dim i As Long, Loletzte As Long, LoI As Long
Application.ScreenUpdating = False
On Error GoTo Fehlerbehandlung
Pfad = "C:\Etikett" 'Verzeichnis für die Etikett-Datei ### ggf. anpassen
With ws1
If [C65536] = "" Then
Loletzte = [C65536].End(xlUp).Row
Else
Loletzte = 65536
End If
For LoI = Loletzte To 2 Step -1
If .Cells(LoI, 2) "" Then Exit For
Next LoI
.PageSetup.PrintArea = "$B$1:$Q$" & LoI + 1 'Printarea
End With
'Prüfen ob Datei Etikett.xls vorhanden
Fehler = 1
Dateiname = Pfad & "\Etikett.xls" ' ### ggf. anpassen
If Dir(Pathname:=Dateiname) = "" Then
MsgBox "Datei """ & Dateiname & """ ist nicht vorhanden!"
GoTo Ende
Else
'Blatt in Datei kopieren
Set wbZiel = Workbooks.Open(FileName:=Dateiname, AddtoMru:=True)
ws1.Copy After:=wbZiel.Sheets(wbZiel.Sheets.Count)
Set wsZiel = ActiveSheet
End If
Fehler = 2
'Blattname festlegen
Blattname = "Lieferant" & ws1.Range("D2").Text ' ### ggf. anpassen
BlattnameFestlegen:
wsZiel.Name = Blattname
Fehler = 3
'Formeln durch Werte ersetzen
wsZiel.UsedRange.Copy
wsZiel.UsedRange.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Textfelder mit zugeordneten Makros löschen
Fehler = 4
wsZiel.Shapes("Textfeld 2").Delete
wsZiel.Shapes("Textfeld 3").Delete
Range("A1").Select
DateiSpeichern:
Fehler = 5
' Bereich für Name "ETI" zuweisen
'direkt einem bestimmten Bereich
wbZiel.Names.Add Name:="ETI", RefersTo:="='" & wsZiel.Name & "'!$B$10:$Q$165"
'oder dynamisch entsprechend vorhandenen Daten _
(Spalten B bis Q ab Zeile 10 bis Ende Daten)
With wsZiel
wbZiel.Names.Add Name:="ETI", RefersTo:="='" & .Name & "'!" & _
.Range(.Cells(10, 2), .Cells(.Rows.Count, 2).End(xlUp).Offset(0, 15)).Address
End With
'Datei Speichern und schließen
wbZiel.Save
wbZiel.Close
Application.ScreenUpdating = True
GoTo Ende
Fehlerbehandlung:
MsgBox "Fehler Nummer " & Err.Number & " ist aufgetreten!" & vbLf & _
Err.Description
Select Case Fehler
Case 1
Case 2
Blattname = InputBox("Der Blattname mit der Lieferantennummer existiert bereits!" _
& vbLf & "Bitte den Blattnamen anpassen." & vbLf _
& "Bei Abbrechen wird das kopierte Blatt wieder gelöscht", _
"Lieferantenblatt kopieren", "Lieferant" _
& ws1.Range("D2").Text) ' ### ggf. anpassen
If Blattname "" Then
Resume BlattnameFestlegen
Else
Application.DisplayAlerts = False
wsZiel.Delete
Application.DisplayAlerts = True
Resume DateiSpeichern
End If
Case 3
Case 4
MsgBox "Die Textfelder zum Kopieren des Blattes konnten nicht gefunden/gelöscht werden!"
Case 5
MsgBox "Problem bei der Zuweisung des Bereichs für Name ""ETI"""
Case Else
End Select
Ende:
Set wbZiel = Nothing: Set ws1 = Nothing: Set wsZiel = Nothing
End Sub