Tab beim Schließen als neue Datei speichern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim wb1 As Workbook, wb2 As Workbook Dim ws1 As Worksheet Set wb1 = ThisWorkbook Set ws1 = wb1.Sheets("Tabelle3") If ws1.Cells(18, 20).Value = "1" Then wb1.Sheets("Auswertung").Copy Set wb2 = ActiveWorkbook wb2.SaveAs (wb1.Path & "\" & Left(wb1.Name, Len(wb1.Name) - 4) & "-" & ws1.Cells(18, 16).Value) End If End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim wb1 As Workbook, wb2 As Workbook Dim ws1 As Worksheet Set wb1 = ThisWorkbook Set ws1 = wb1.Sheets("Tabelle3") test = Dir(wb1.Path & "\" & Left(wb1.Name, Len(wb1.Name) - 4) & "-" & ws1.Cells(18, 16).Value) If test = "" Then If ws1.Cells(18, 20).Value = "1" Then wb1.Sheets("Auswertung").Copy Set wb2 = ActiveWorkbook On Error Resume Next Application.DisplayAlerts = False wb2.SaveAs (wb1.Path & "\" & Left(wb1.Name, Len(wb1.Name) - 4) & "-" & ws1.Cells(18, 16).Value) Application.DisplayAlerts = True wb2.Close Savechanges:=True Set wb2 = Nothing End If End If End Sub

Hallo Veit,
vielen Dank, dass Du noch kurz geantwortet hast.
Vaterpflichten gehen vor, das ist selbstverständlich.
Habe folgenden Lösungsvorschlag, bei dem Du mir bei der weiteren Umsetzung (später!!) gerne weiterhelfen kannst (es eilt in keinem Fall!).
Ich habe ein Makro aufgezeichnet, das folgendes bewirkt:
Kopie des Tabellenblattes "Auswertungen" in der Datei und entsprechende Änderungen (Bereiche gelöscht bzw. kopiert und als Werte eingefügt). Die Kopie der Tabelle "Auswertungen trägt folglich den Namen "Auswertungen (2)". Das Makro trägt den Namen "Auswertung_kopieren"
Jetzt müsste man meinen Vorstellungen das bisherige Makro beim Schließen der Datei wie folgt ändern:
Wenn beim Schließen der Datei die Voraussetzungen für das Anlegen der neuen Datei erfüllt sind, müsste nun zuerst das Makro "Auswertung_kopieren" gestartet werden. Anschließend müsste dann nicht die Tabelle "Auswertung" sondern "Auswertung (2)" in die neue Datei (nicht kopiert sondern) verschoben werden (Dateibezeichnung wie bei der alten Lösung).
Kann man das so realisieren.
Bereits an dieser Stelle vielen Dank! Wie gesagt: zuerst Vaterpflichten erfüllen.
In diesem Sinne
Gruß
Fritz

Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim strW As String, wb2 As Workbook, lngZ As Long, intC As Integer With ThisWorkbook strW = Left(.FullName, Len(.FullName) - 4) & _ "-" & .Sheets("Tabelle3").Cells(18, 16) & ".xls" If Dir(strW) = "" Then If .Sheets("Tabelle3").Cells(18, 20) = "1" Then With .Sheets("Auswertung") lngZ = .UsedRange.Row + .UsedRange.Rows.Count - 1 intC = .UsedRange.Column + .UsedRange.Columns.Count - 1 ' anlegen, kopieren (auch Formate) .Copy Set wb2 = ActiveWorkbook ' nur Werte, keine Formeln If lngZ * intC > 0 Then _ wb2.Sheets(1).Range(Cells(1, 1), Cells(lngZ, intC)) = _ .Range(.Cells(1, 1), .Cells(lngZ, intC)).Value End With ' speichern, schließen wb2.SaveAs strW wb2.Close Set wb2 = Nothing End If Else MsgBox strW & vbLf & "gibt es schon.", vbInformation End If End With End Sub

Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim strW As String, wb2 As Workbook, lngZ As Long, intC As Integer, objShape As Shape With ThisWorkbook strW = Left(.FullName, Len(.FullName) - 4) & _ "-" & .Sheets("Tabelle3").Cells(18, 16) & ".xls" If Dir(strW) = "" Then If .Sheets("Tabelle3").Cells(18, 20) = "1" Then With .Sheets("Auswertung") lngZ = .UsedRange.Row + .UsedRange.Rows.Count - 1 intC = .UsedRange.Column + .UsedRange.Columns.Count - 1 ' anlegen, kopieren (auch Formate) .Copy Set wb2 = ActiveWorkbook ' Schaltflächen löschen For Each objShape In ActiveSheet.Shapes objShape.Delete Next objShape ' nur Werte, keine Formeln If lngZ * intC > 0 Then _ Range(Cells(1, 1), Cells(lngZ, intC)) = _ .Range(.Cells(1, 1), .Cells(lngZ, intC)).Value End With ' speichern, schließen wb2.SaveAs strW wb2.Close Set wb2 = Nothing End If Else MsgBox strW & vbLf & "gibt es schon.", vbInformation End If End With End Sub

Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim strW As String, wb2 As Workbook, lngZ As Long, intC As Integer, objShape As Shape With ThisWorkbook strW = Left(.FullName, Len(.FullName) - 4) & _ "-" & .Sheets("Tabelle3").Cells(18, 16) & ".xls" If Dir(strW) = "" Then If .Sheets("Tabelle3").Cells(18, 20) = "1" Then With .Worksheets("Auswertung") lngZ = .UsedRange.Row + .UsedRange.Rows.Count - 1 intC = .UsedRange.Column + .UsedRange.Columns.Count - 1 ' anlegen, kopieren (auch Formate) .Copy Set wb2 = ActiveWorkbook ' Schaltflächen löschen For Each objShape In wb2.Sheets(1).Shapes objShape.Delete Next objShape ' nur Werte, keine Formeln If lngZ * intC > 0 Then _ Range(Cells(1, 1), Cells(lngZ, intC)) = _ .Range(.Cells(1, 1), .Cells(lngZ, intC)).Value End With ' speichern, schließen wb2.SaveAs strW wb2.Close Set wb2 = Nothing End If Else MsgBox strW & vbLf & "gibt es schon.", vbInformation End If End With End Sub

Hi Fritz,
das ginge (hoffentlich) so:

Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim strW As String, wb2 As Workbook, lngZ As Long, intC As Integer, objShape As Shape
Dim ws2 As Worksheet
With ThisWorkbook
strW = Left(.FullName, Len(.FullName) - 4) & _
"-" & .Sheets("Tabelle3").Cells(18, 16) & ".xls"
If Dir(strW) = "" Then
If .Sheets("Tabelle3").Cells(18, 20) = "1" Then
With .Worksheets("Auswertung")
lngZ = .UsedRange.Row + .UsedRange.Rows.Count - 1
intC = .UsedRange.Column + .UsedRange.Columns.Count - 1
'                                                     anlegen, kopieren (auch Formate)
.Copy
Set wb2 = ActiveWorkbook
Set ws2 = wb2.Sheets(1)
'                                                     Schaltflächen löschen
For Each objShape In ws2.Shapes
objShape.Delete
Next objShape
'                                                     nur Werte, keine Formeln
If lngZ * intC > 0 Then _
Range(Cells(1, 1), Cells(lngZ, intC)) = _
.Range(.Cells(1, 1), .Cells(lngZ, intC)).Value
'                                                     Blattschutz für die Kopie
ws2.Protect "xXx"
End With
'                                                     speichern, schließen
wb2.SaveAs strW
wb2.Close
Set wb2 = Nothing
Set ws2 = Nothing
End If
Else
MsgBox strW & vbLf & "gibt es schon.", vbInformation
End If
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

Tab beim Schließen als neue Datei speichern

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tab beim Schließen als neue Datei speichern

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread