Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
948to952
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
948to952
948to952
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

anfügen Tabelleblätter in Neue Datei

anfügen Tabelleblätter in Neue Datei
07.02.2008 22:16:58
Karel
Guten Abend an alle,
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: anfügen Tabelleblätter in Neue Datei
08.02.2008 08:45:00
fcs
Hallo Karel,
wie willst du weitere Blätter anhängen?
a) Die Neue Datei bleibt geöffnet bis eine Abfrage ob weitere Blätter angehängt werden sollen mit Nein beantworttet wird.
b) Die Neue Datei wird jeweils gespeichert und geschlossen. nach Rückfrage kannst du entscheiden ob das Blatt in eine neue Datei oder in einer vorhandenen Datei angehängt werden soll. ggf. wird dann der Dateiauswahldialog angezeigt.
Gruß
Franz

AW: anfügen Tabelleblätter in Neue Datei
08.02.2008 22:19:22
Karel
Hallo Franz,
Freut mich von dir wieder zu hören.
wie willst du weitere Blätter anhängen?
ANTWORT A
a) Die Neue Datei bleibt geöffnet bis eine Abfrage ob weitere Blätter angehängt werden sollen mit Nein beantworttet wird.
wird bei Neue Datei wenn Neues Blatt angefügt wird automatisch zwischen gespeichert?
viele Grusse
Karel

Anzeige
AW: anfügen Tabelleblätter in Neue Datei
11.02.2008 20:06:10
fcs
Hallo Karel,
hier der angepasste Code, um mehrere Blatter in eine neue Ettikettdatei zu kopieren.
Der Name der Etikett-Datei wird dabei im Speichern-Unter-Dialog abgefragt.
Die neue Datei wird nach jedem eingefügten Blatt gespeichert.
Sollen keine weiteren Blätter eingefügt werden, dann wird die neue Ettikett-Datei geschlossen.
Die Zeile
Public wbZiel As Workbook
mit der Variablen-Deklaration muss dabei am Anfang des Codes im Modul stehen.
Gruß
Franz

Public wbZiel As Workbook
Sub Copy_mehrmals_to_Etikett()
Dim ws1 As Worksheet, wsZiel As Worksheet, Zeile As Long
Dim Pfad As String, Dateiname As String, Blattname As String
Dim Fehler As Integer
Set ws1 = ThisWorkbook.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
If wbZiel Is Nothing Then
'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
End If
Set wbZiel = Workbooks.Open(FileName:=Dateiname, AddtoMru:=True)
'Datei Speichern  - Dialog wird angezeigt
Application.ScreenUpdating = True
Application.Dialogs(xlDialogSaveAs).Show "Etikett_" & Format(Date, "YYYYMMDD") & ".xls"
'wbZiel.SaveAs FileName:=Pfad & "\" & "abc" & ".xls"
'Farbtabelle übertragen
For i = 1 To 56
wbZiel.Colors(i) = ThisWorkbook.Colors(i)
Next
Else
wbZiel.Activate
End If
'Blatt in Datei kopieren
ws1.Copy After:=wbZiel.Sheets(wbZiel.Sheets.Count)
Set wsZiel = ActiveSheet
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
'Inhalt in Zellen mit Leerstring entfernen
With wsZiel
For Zeile = .Cells(.Rows.Count, 2).End(xlUp).Row To 9 Step -1
If .Cells(Zeile, 2).Value  "" Then Zeile = Zeile + 1: Exit For
Next
.Range(.Rows(Zeile), .Rows(Application.WorksheetFunction.Max(10, ._
Cells(.Rows.Count, 2).End(xlUp).Row))).ClearContents
End With
'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
Fehler = 5
' Bereich für Name "ETI....." zuweisen
' dynamisch entsprechend vorhandenen Daten _
(Spalten B bis Q ab Zeile 10 bis Ende Daten)
With wsZiel
wbZiel.Names.Add Name:="ETI_" & ActiveSheet.Name, RefersTo:="='" & .Name & "'!" & _
.Range(.Cells(10, 2), .Cells(.Rows.Count, 2).End(xlUp).Offset(0, 15)).Address
End With
DateiSpeichern:
'Datei Speichern und ggf. schließen
wbZiel.Save
If MsgBox("Weiteres Tabellenblatt anfügen?", vbYesNo + vbQuestion, _
"Lieferantenblatt kopieren") = vbYes Then
ThisWorkbook.Activate
Else
wbZiel.Close
Set wbZiel = Nothing
End If
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", "S" _
& 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 ws1 = Nothing: Set wsZiel = Nothing
End Sub


Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige