Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1884to1888
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
Inhaltsverzeichnis

TBL-Blatt ohne Code Speichern

TBL-Blatt ohne Code Speichern
12.06.2022 13:31:37
Andreas
Hallo,
mit dem folgenden Makro Speichere ich meine Arbeit in einem anderen Ordner.
Damit werden die "Tabelle1", das "Deckblatt" sowie "Bearbeiten" gespeichert.
Nun wird aber aus dem "Deckblatt" ein Code, der im Tabellenblatt steht, mit kopiert.
Dieser Code wird jedoch im gespeicherten Neuen Ordner nicht mehr benötigt, und er verursacht hier Fehler.
Ist es möglich, beim Speichern des TBL.Blatt "Deckblatt" im Neuen Ordner diesen Code oben zu Löschen?
Fehler ist- es gibt das Worksheets("Hilfstabelle EINGABE") im Neuen Ordner nicht.
Was könnte ich tun?
Der Code lautet:

Option Explicit
Private Sub Worksheet_Activate()
Dim objShap As Shape
Dim blnFound As Boolean
With Worksheets("Deckblatt")
For Each objShap In .Shapes
If Not Intersect(objShap.TopLeftCell, .Range("A43:M50")) Is Nothing Or _
Not Intersect(objShap.BottomRightCell, .Range("A43:M50")) Is Nothing Then
blnFound = True
Set objShap = Nothing
Exit For
End If
Next
End With
Worksheets("Hilfstabelle EINGABE").[Z6].Interior.Color = IIf(blnFound, vbWhite, vbGreen)
Worksheets("Hilfstabelle EINGABE").[Z7].Interior.Color = IIf(blnFound, vbGreen, vbWhite)
End Sub
Ist es möglich, beim Speichern des TBL.Blatt "Deckblatt" im Neuen Ordner diesen Code oben zu Löschen?

Public Sub Speichern_in_PDF_XLSX()
Dim varPath As Variant
Dim strDir As String
Dim wkb As Workbook, wkbCopy As Workbook, bolSpeichern As Boolean
On Error GoTo Fin
Sheets("Tabelle1").Select
varPath = Application.GetSaveAsFilename( _
InitialFileName:="D:\Desktop\PDF_Brennordner", _
FileFilter:="Excel(*.xlsx), *.xlsx", _
Title:="Save as XLSX and PDF")
If Not varPath = False Then
strDir = Left(varPath, InStrRev(varPath, "\"))
Set wkb = ActiveWorkbook
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
If Dir(varPath)  "" Then
Select Case MsgBox("Datei überschreiben?", 4 + 32 + 0, "Datei")
Case vbYes
bolSpeichern = True
Case Else
GoTo Fin
End Select
Else
bolSpeichern = True
End If
Windows("Vorlage.xlsm").Activate
Sheets("Tabelle1").Select
Range("B20").Select
''''ActiveCell.FormulaR1C1 = " "
Range("N19").Select
If bolSpeichern = True Then
wkb.Sheets("Tabelle1").Copy
Set wkbCopy = ActiveWorkbook
With wkbCopy
wkb.Sheets("Deckblatt").Copy After:=.Sheets(1)
wkb.Sheets("Bearbeiten").Copy After:=.Sheets(2)
.SaveAs varPath, 51
.Close False
End With
Set wkbCopy = Nothing
With wkb
.Worksheets("Tabelle1").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strDir & "Tabelle1 " & Format(Date, "YYYY-MM") & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=True
.Worksheets("Deckblatt").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=strDir & "Deckblatt " & Format(Date, "YYYY-MM") & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=True
End With
Set wkb = Nothing
End If
Else
MsgBox "Abgebrochen..."
End If
Fin:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description
On Error Resume Next
With Sheets("Deckblatt")  'grün
.Tab.Color = _
RGB(0, 255, 0)
.Tab.TintAndShade = 0
End With
On Error Resume Next
With Sheets("Tabelle1")  'grün
.Tab.Color = _
RGB(0, 255, 0)
.Tab.TintAndShade = 0
End With
On Error Resume Next
With Sheets("Bearbeiten")  'grün
.Tab.Color = _
RGB(0, 255, 0)
.Tab.TintAndShade = 0
End With
On Error Resume Next
With Sheets("Bestand_Bearb.")  'grün
.Tab.Color = _
RGB(0, 255, 0)
.Tab.TintAndShade = 0
End With
End Sub
Gruß Andreas

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: TBL-Blatt ohne Code Speichern
12.06.2022 14:29:31
Andreas
Habe es erst mal so entschärft- Funktioniert erst mal-

On Error Resume Next
Worksheets("Hilfstabelle EINGABE").[Z6].Interior.Color = IIf(blnFound, vbWhite, vbGreen)
On Error Resume Next
Worksheets("Hilfstabelle EINGABE").[Z7].Interior.Color = IIf(blnFound, vbGreen, vbWhite)
On Error GoTo 0

AW: TBL-Blatt ohne Code Speichern
12.06.2022 15:02:56
Oberschlumpf
Hi Andreas,
aber 1x Zeile mit Resume Next kannste dir sparen, weil überflüssig.
Ciao
Thorsten
AW: TBL-Blatt ohne Code Speichern
13.06.2022 13:28:37
Daniel
Hi
kommt darauf an.
ist das der einzige Code im Tabellenblatt?
willst du generell ohne Codes speichern oder gibt es weitere Codes, welche nicht gelöscht werden sollen?
wenn es weitere Codes gibt, die laufen sollen, dann würde ich bei den Kritischen Codes eine Abfrage einbauen, ob sie ausgeführt werden können oder nicht.
beim ersten Makro muss ja das Tabellenblatt "Hilfstabelle Eingabe" vorhanden sein. Das kannst du prüfen, am einfachsten mit diesem Code am Anfang des Makros:

IF IsError(Evaluate("'Hilfstabelle EINGABE'!A1")) then exit sub
hier dann der weitere Code
den Tabellenblattnamen solltest du immer in Hochkommas setzen.
Gruß Daniel
Anzeige
Man sollte nach dazu schreiben...
13.06.2022 19:31:33
{Boris}
Hi Daniel,
...dass dann in 'Hilfstabelle EINGABE'!A1 auch kein Fehlerwert stehen darf, da der Code dann auch abbricht (obwohl das Blatt existiert).
Daher würde ich Blätter besser so auf ihr Vorhandensein prüfen:

Dim s As String
On Error Resume Next
s = Worksheets("Blattname").Name
On Error Goto 0
If Len(s) = 0 Then Exit Sub
VG, Boris
AW: TBL-Blatt ohne Code Speichern
13.06.2022 14:27:54
GerdL
Hallo Andreas,
in der Ursprungsdatei könntest du das erste Makro so inetwa ins Modul "DieseArbeitsmappe" verlagern, das zweite in ein Standardmodul, z.B. Modul1.

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim objShap As Shape
Dim blnFound As Boolean
If Sh.Name = "Deckblatt" Then
With Sh
For Each objShap In Sh.Shapes
If Not Intersect(objShap.TopLeftCell, .Range("A43:M50")) Is Nothing Or _
Not Intersect(objShap.BottomRightCell, .Range("A43:M50")) Is Nothing Then
blnFound = True
Set objShap = Nothing
Exit For
End If
Next
End With
With Worksheets("Hilfstabelle EINGABE")
.Range("Z6").Interior.Color = IIf(blnFound, vbWhite, vbGreen)
.Range("Z7").Interior.Color = IIf(blnFound, vbGreen, vbWhite)
End With
End If
End Sub
Gruß Gerd

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige