anfügen Tabelleblätter in Neue Datei
07.02.2008 22:16:58
Karel
Mein Thread ist leider nicht mehr Aktuell
https://www.herber.de/forum/archiv/944to948/t947766.htm#947766
Habe mit große Unterstutzung von Franz unterstehende Code zusammen bekommen.
Blatt wird unter bestimmte Name abgespeichert in ein andere Datei (C:\Etikett\ name) Lauft alle perfekt
Mein Letzte Frage an Franz wahr:
Ein Problem habe ich noch Blätter werden in Arbeitblatt Etikett kopiert, aber Etikett dient eigentlich nur als Vorlage, kann man über eine Inputbox Arbeitsblatt unter eine andere Name Speichern. Arbeitsblatt Etikett sollte nicht verändert werden
Antwort Franz
um die Etikett-Datei mit dem eingfügten Blatt unter einem anderen Namen zu speichern hast du 2 Möglichkeiten:
1. Im Code wird der Dateiname automatisch generiert und die Datei gespeichert
2. Der Dialog "Speichern unter" wird angezeigt.
Nachfolgend der anzupassende Codeabschnitt für beide Varianten.
'Datei Speichern und schließen - direkt, Name wird automatisch generiert
wbZiel.Activate
Application.ScreenUpdating = True
wbZiel.SaveAs FileName:=wbZiel.Path & "\Ettikett_" & Blattname & _
Format(wsZiel.Range("D6"), "_YYYYMMDD") & ".xls", addtomru:=True
wbZiel.Close
GoTo Ende
'Datei Speichern und schließen - Dialog wird angezeigt
wbZiel.Activate
Application.ScreenUpdating = True
If Application.Dialogs(xlDialogSaveAs).Show = True Then
wbZiel.Close
End If
GoTo Ende
Meine eigentliche Frage, ich muss die Möglichkeit habe mehrere Tabelleblatte in der neue Datei anzufügen. Will dass gerne Variable gestalten denke dabei an Variante wenn z.B. in Zelle E1 text
Mehrfach steht dann kann Tabelleblatt unbegrenzt in Neue Datei angefügt werden.
Steht in Zelle text einmall dann kann nur einmall Tabelleblatt angefügt werden.
Anbei letzte komplett Code
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
'Farbtabelle übertragen
For i = 1 To 56
wbZiel.Colors(i) = ThisWorkbook.Colors(i)
Next
End If
Fehler = 2
'Blattname festlegen
Blattname = "S" & 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.DrawingObjects.Delete ' alle objecten löschen
'wsZiel.Shapes("Textfeld 11").Delete
'wsZiel.Shapes("Textfeld 12").Delete
Range("A1").Select
DateiSpeichern:
Fehler = 5
' Bereich für Name "ETI" zuweisen
'direkt einem bestimmten Bereich
wbZiel.Names.Add Name:=ActiveSheet.Name, RefersTo:="='" & wsZiel.Name & "'!$C$10:$Q$165"
'oder dynamisch entsprechend vorhandenen Daten _
(Spalten B bis Q ab Zeile 10 bis Ende Daten)
With wsZiel
wbZiel.Names.Add Name:=ActiveSheet.Name, 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
Viele Grusse
Karel