Sheet kopieren

Hallo an alle, komme mal wieder nicht weiter. Habe folgendes Makro zum kopieren eines Sheets in eine andere Mappe.

Sub Active_Sheet_Copy_Neu()
Dim WKB As Workbook Dim wks As Worksheet Dim strDatei As String Dim strFullname As String Const Pfad As String = "C:\Users\luna\Desktop\Bufete\Gesamt\" Set wks = ActiveSheet strDatei = Year(Trim$(wks.Range("A3").Text)) strFullname = Pfad & "Abrechnung Gesamt " & strDatei & ".xlsm" Set WKB = Workbooks.Open(Filename:=strFullname) wks.Copy After:=WKB.Worksheets(Sheets.Count) 'Formeln durch Werte ersetzen: With ActiveSheet.UsedRange .Value = .Value End With ActiveSheet.Shapes.Range(Array("Button 1;8")).Select Selection.Delete ActiveSheet.Shapes.Range(Array("Button 4")).Select Selection.Delete ActiveSheet.Shapes.Range(Array("Button 5")).Select Selection.Delete ActiveSheet.Shapes.Range(Array("Option Button 2")).Select Selection.Delete ActiveSheet.Shapes.Range(Array("Lst_Währung")).Select Selection.Delete WKB.Close SaveChanges:=True Set wks = Nothing Set WKB = Nothing End Sub
Wie bekomme ich da jetzt eine Überprüfung hinein. Ich möchte prüfen ob in der Zielmappe das Blatt schon existiert, wenn JA dann bitte nach Abfrage (ja,nein) überschreiben und wenn NEIN einfügen. Jetzt fügt er es mir zB 0010 natürlich einfach ein mit 0010(2). Die Sheets aus der Quelldatei sind immer 4 stellig und übernehmen den Namen aus Zelle C2. Als Zieldatei kommt es darauf an welches Datum in A3 steht. Darauf hin wir nach Abrechnung Gesamt 2012, 2013 usw verteilt. Wer kann mir helfen?
Danke euch allen
Luna

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Active_Sheet_Copy_Neu() Dim WKB As Workbook Dim wks As Worksheet, wksTest Dim strDatei As String Dim strFullname As String Const Pfad As String = "C:\Users\luna\Desktop\Bufete\Gesamt\" Set wks = ActiveSheet strDatei = Year(Trim$(wks.Range("A3").Text)) strFullname = Pfad & "Abrechnung Gesamt " & strDatei & ".xlsm" Set WKB = Workbooks.Open(Filename:=strFullname) On Error Resume Next Set wksTest = WKB.Sheets(wks.Name) On Error GoTo 0 If Not wksTest Is Nothing Then If MsgBox("Blatt existiert" & vbLf & "Überschreiben?", vbYesNo, "Frage") = vbYes Then Application.DisplayAlerts = False wksTest.Delete Application.DisplayAlerts = True Else MsgBox "Abbruch" GoTo exitsub End If End If wks.Copy After:=WKB.Worksheets(Sheets.Count) 'Formeln durch Werte ersetzen: With ActiveSheet.UsedRange .Value = .Value End With ActiveSheet.Shapes.Range(Array("Button 1;8")).Select Selection.Delete ActiveSheet.Shapes.Range(Array("Button 4")).Select Selection.Delete ActiveSheet.Shapes.Range(Array("Button 5")).Select Selection.Delete ActiveSheet.Shapes.Range(Array("Option Button 2")).Select Selection.Delete ActiveSheet.Shapes.Range(Array("Lst_Währung")).Select Selection.Delete WKB.Close SaveChanges:=True exitsub: Set wks = Nothing Set WKB = Nothing Set wksTest = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread