Blatt kopieren - knifflig | HERBERS Excel Forum

Hallo an alle,
ich bin anscheinend auf der Suche nach der "eierlegenden Wollmilchsau" u. im Archiv leider nicht so recht fündig geworden... :-((
Zwecks Archivierung möchte ich ein Tabellenblatt in eine andere, bestehende Datei kopieren (mittels CommandButton).
Besonderheiten sind allerdings:
1. Die Zieldatei liegt in einem anderen Verzeichnis.
2. Es soll NUR das Blatt (als eine Art Sreenshot), also NUR seine Werte u. Formatierungen kopiert werden, OHNE den dahinterliegenden VBA-Code u. OHNE irgendwelche Verknüpfungen, Formeln, Kommentare oder Bereichsnamen.
3. Die Kopie soll jeweils an das Ende der Zieldatei gestellt werden, wobei eine Abfrage erfolgen müsste, unter welchem Registernamen sie dort angelegt werden soll. (s. evtl 2. Code)
4. Die Zieldatei muss ggf. vorher automatisch geöffnet werden.
Folgende 2 Anregungen habe ich bereits im Archiv gefunden - vielleicht helfen sie Euch weiter:
CODE 1


Sub Belegkopie_erstellen()
Dim myFileName As String, mySavePfad As String
'Hier bitte anpassen
mySavePfad = "D:\Datenbank\Sicherheitskopien\" 'Mit Backslash am Schluss !!!
myFileName = Range("L12").Text
Application.DisplayAlerts = False
Application.ScreenUpdating = False
ActiveSheet.Copy
Cells.Select
Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Cells(1, 1).Select
ActiveWorkbook.SaveAs Filename:=mySavePfad & myFileName
Workbooks(myFileName & ".xls").Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

CODE 2


Sub NeuesTabBlatt()
Dim NewName As String
ActiveSheet.Copy Before:=ActiveSheet
NewName = InputBox("Geben Sie einen Tabellenblattnamen ein")
ActiveSheet.Name = NewName
End Sub

Bitte entschuldigt die Vielzahl der besonderen Anforderungen.
Damit möchte ich keinesfalls gegen die Forumsregeln verstossen.
Ich wollte damit nur das Gesamtziel darstellen u. freue mich natürlich auch über Teillösungen...
MfG Dirk N.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton1_Click() Application.ScreenUpdating = False Dim ns, wb2, sh1, nsname Set sh1 = ActiveWorkbook.ActiveSheet Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\zieldatei.xls") Set ns = wb2.Sheets.Add(, Sheets(wb2.Sheets.Count)) nsname = InputBox("Neues Arbeitsblatt in der Zieldatei benennen!", "ABL benennen") If nsname = "" Then nsname = "FUP" For d = 1 To wb2.Sheets.Count If wb2.Sheets(d).Name = nsname Then nsname = "ABL " & Day(Date) & "." & _ Month(Date) & "." & Year(Date) & " " & Hour(Time) & "-" & _ Minute(Time) & "-" & Second(Time) & " Uhr" Next d ns.Name = nsname sh1.UsedRange.Copy ns.Range("a1").PasteSpecial (xlPasteFormats) ns.Range("a1").PasteSpecial (xlPasteColumnWidths) ns.Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats) wb2.Save wb2.Close Application.ScreenUpdating = True Set ns = Nothing Set wb2 = Nothing Set sh1 = Nothing End Sub

Sub Fruehsport() With ThisWorkbook .Sheets.Add After:=.Sheets(Sheets.Count) .Worksheets("Tabelle1").UsedRange.Copy .Sheets(.Sheets.Count).Cells(1, 1).PasteSpecial (xlPasteValues) .Sheets(.Sheets.Count).Cells(1, 1).PasteSpecial (xlPasteFormats) ActiveSheet.Name = InputBox("Name") Workbooks.Open ("C:\Eigene Dateien\ttt.xls") .Sheets(.Sheets.Count).Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count) End With End Sub

Application.ScreenUpdating = False Dim ns, wb2, sh1, nsname, wbopen Set sh1 = ActiveWorkbook.ActiveSheet Dim openworkbook As Workbook wbopen = False For Each openworkbook In Workbooks If openworkbook.Name = "Zieldatei.xls" And openworkbook.Path = ActiveWorkbook.Path Then wbopen = True openworkbook.Save openworkbook.Close Exit For End If Next Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\zieldatei.xls") nsname = InputBox("Neues Arbeitsblatt in der Zieldatei benennen!", "ABL benennen") If nsname = "" Then GoTo Abbruch For d = 1 To wb2.Sheets.Count If wb2.Sheets(d).Name = nsname Then nsname = "ABL " & Day(Date) & "." & _ Month(Date) & "." & Year(Date) & " " & Hour(Time) & _ "-" & Minute(Time) & "-" & Second(Time) & " Uhr" Next d Set ns = wb2.Sheets.Add(, Sheets(wb2.Sheets.Count)) ns.Name = nsname sh1.UsedRange.Copy ns.Range("a1").PasteSpecial (xlPasteFormats) ns.Range("a1").PasteSpecial (xlPasteColumnWidths) ns.Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats) For i = 1 To sh1.UsedRange.Rows.Count ns.Rows(i).RowHeight = sh1.UsedRange.Rows(i).RowHeight Next i Abbruch: If nsname = "" Then MsgBox "Kein gueltiger Name oder Abbruch... Kopie nicht erstellt!" wb2.Save If wbopen = False Then wb2.Close ThisWorkbook.Activate Application.ScreenUpdating = True Set ns = Nothing Set wb2 = Nothing Set sh1 = Nothing

Hallo Rainer,
vielen Dank für deine Geduld mit mir u. deinen neuen Vorschlag !
Sämtliche Formate werden nun exakt übertragen u. auch das Problem mit der Fehlermeldung bei geöffneter Zieldatei hast du super gelöst - Kompliment !
Allerdings gibt es noch 2 letzte "Schönheitsfehler" aus meiner Sicht:
1. Ist die Zieldatei bereits offen UND es erfolgt eine Eingabe in der InputBox, so soll das Blatt kopiert werden und das neue Blatt in der Zieldatei aktiviert werden.
(Bei Abbrechen bzw. keine Eingabe bleibe in der Quelldatei u. kopiere nicht - dies funktioniert ja schon.)
2. Ist die Zieldatei geschlossen UND es erfolgt eine Eingabe in der InputBox, so soll das Blatt kopiert werden und das neue Blatt in der Zieldatei aktiviert werden - momentan wird die Zieldatei leider gleich wieder geschlossen.
(Bei Abbrechen bzw. keine Eingabe bleibe in der Quelldatei u. kopiere nicht, lasse die Zieldatei geschlossen - dies funktioniert ja schon.)
Hintergrund: Nach dem Kopieren muss ich in der Zieldatei einige manuelle Änderungen vornehmen.
Ich hoffe, du hast noch Lust mir abschließend zu helfen.
Zwar habe ich schon einiges mit deinem letzten Code experimentiert, aber ich kriege es einfach nicht hin...
MfG Dirk

Private Sub CommandButton1_Click() Application.ScreenUpdating = False Dim ns, wb2, sh1, nsname, wbopen, abbr Set sh1 = ActiveWorkbook.ActiveSheet Dim openworkbook As Workbook wbopen = False For Each openworkbook In Workbooks If openworkbook.Name = "Zieldatei.xls" And openworkbook.Path = ActiveWorkbook.Path Then wbopen = True openworkbook.Save openworkbook.Close Exit For End If Next Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\zieldatei.xls") nsname = InputBox("Neues Arbeitsblatt in der Zieldatei benennen!", "ABL benennen") If nsname = "" Then abbr = True: GoTo abbruch For d = 1 To wb2.Sheets.Count If wb2.Sheets(d).Name = nsname Then nsname = "ABL " & Day(Date) & "." & _ Month(Date) & "." & Year(Date) & " " & _ Hour(Time) & "-" & Minute(Time) & "-" _ & Second(Time) & " Uhr" Next d Set ns = wb2.Sheets.Add(, Sheets(wb2.Sheets.Count)) ns.Name = nsname sh1.UsedRange.Copy ns.Range("a1").PasteSpecial (xlPasteFormats) ns.Range("a1").PasteSpecial (xlPasteColumnWidths) ns.Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats) For i = 1 To sh1.UsedRange.Rows.Count ns.Rows(i).RowHeight = sh1.UsedRange.Rows(i).RowHeight Next i abbruch: If nsname = "" Then MsgBox "Kein gueltiger Name oder Abbruch... Kopie nicht erstellt!" wb2.Save If abbr = True Then sh1.Activate Else ns.Activate ns.Range("a1").Select End If Application.ScreenUpdating = True Set ns = Nothing Set wb2 = Nothing Set sh1 = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Blatt kopieren - knifflig

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Blatt kopieren - knifflig

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread