If ohne End If Block
10.05.2021 19:06:44
MarcoH
ich habe ein kleines Problem mit der Fehlermeldung If ohne End If Block. Meines Erachtens habe ich alle erforderlichen End Ifs gesetzt. Vielleicht bin ich bei dem langen Code auch einfach nur blind geworden.
Bei der Fehlermeldung ist der Sub und End Sub gelb markiert.
Ich habe bereits einiges probiert, jedoch keinen Fehler etc gefunden.
Ich hoffe, dass ihr mir helfen könnt.
Die Datei kann ich aufgrund der sehr sensiblen Daten und auch Tabellen nicht einstellen. Ich hoffe, dass der Code an sich genügt.
Vielen Dank im Voraus für die Hilfe!!
Hier der Code:
Sub BesiProtokoll_verwalten()
' 1. Verwalten und in das Betriebsbuch übertragen
Worksheets("Protokoll").Visible = True
Worksheets("Protokoll").Activate
Worksheets("Protokoll").Unprotect
Worksheets("Betriebsbuch").Unprotect
'Bereich kopieren
Sheets("Protokoll").Range("L18:U29").Copy
'einfügen in erste freie Zeile in Betriebsbuch
Sheets("Betriebsbuch").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'Kopiermodus beenden
Application.CutCopyMode = False
Worksheets("Protokoll").Protect
Worksheets("Ausfüllhilfe").Activate
' Drucken / per Mail
'**Szenario 1 = Kein Material entstanden, dann per Mail an ?
If Range("H43") = 0 Then
'** Das aktive Tabellenblatt wird über Outlook versendet
'** Dimensionierung der Variablen
Dim strBlatt As String
Dim strDatei As String
Dim strPfad As String
Dim outObj As Object
Dim Mail As Object
Dim strBodyText As String
Dim strSubjectText As String
If Range("H4") = "Verwaltet!" Then
MsgBox "SENSIBEL"
Else
Worksheets("Ausfüllhilfe").Activate
Sheets("Ausfüllhilfe").Unprotect
Range("H4") = "Verwaltet!"
Sheets("Ausfüllhilfe").Protect
Worksheets("Protokoll").Activate
Sheets("Protokoll").Unprotect
Range("A37") = "XYXY versendet durch" & Range("H47").Value
'** Einfärbung der Zellen B1
If Range("B21") = "" And Range("C21") = "" Then
Range("B20:C21").Interior.Color = vbBlack
ElseIf Range("B21") = "x" Then
Range("C20:C21").Interior.Color = vbBlack
ElseIf Range("C21") = "x" Then
Range("B20:B21").Interior.Color = vbBlack
'** Einfärbung Zellen B2
If Range("D21") = "" And Range("C21") = "" Then
Range("D20:E21").Interior.Color = vbBlack
ElseIf Range("D21") = "x" Then
Range("E20:E21").Interior.Color = vbBlack
ElseIf Range("E21") = "x" Then
Range("D20:D21").Interior.Color = vbBlack
'** Einfärben Zellen B3
If Range("F21") = "" And Range("C21") = "" Then
Range("F20:G21").Interior.Color = vbBlack
ElseIf Range("F21") = "x" Then
Range("G20:G21").Interior.Color = vbBlack
ElseIf Range("G21") = "x" Then
Range("F20:F21").Interior.Color = vbBlack
'** Einfärben Zellen B4
If Range("H21") = "" And Range("C21") = "" Then
Range("H20:I21").Interior.Color = vbBlack
ElseIf Range("H21") = "x" Then
Range("I20:I21").Interior.Color = vbBlack
ElseIf Range("I21") = "x" Then
Range("H20:H21").Interior.Color = vbBlack
End If
Worksheets("BeSi Protokoll").Protect
'** Versenden per Mail
Set outObj = CreateObject("Outlook.Application")
Set Mail = outObj.CreateItem(0)
'** Pfad für temporäre Zwischenspeicherung angeben
strPfad = "C:\Temp" 'entsprechend anpassen
'** Aktuelles aktives Blatt in neue Arbeitsmappe kopieren
strBlatt = ActiveSheet.Name
'** Gewähltes Tabellenblatt kopieren
Sheets(strBlatt).Copy
'** Blatt temporär in vorgegebenes Verzeichnis abspeichern
ActiveWorkbook.SaveAs strPfad & "\" & ActiveSheet.Name, FileFormat:=xlOpenXMLWorkbookMacroEnabled
'** Pfad und Dateiname der neuen Datei zwischenspeichern
strDatei = ActiveWorkbook.FullName
'** Betreff-Text festlegen
strSubjectText = "Negativprotokoll " & Range("B11").Value
'** Nachrichten-Text festlegen
strBodyText = "" & "Sehr geehrte Damen und Herren,
" & _
"BLABLABLA.
" & _
"Mit freundlichen Grüßen.
" & _
"gez. " & Range("B18").Value & "
" & _
Range("A42").Value & "
"
'** Mail erzeugen
With Mail
.To = "SENSIBEL" 'Empfänger
.CC = Range("A43") 'Kopie an Empfänger
.Subject = strSubjectText 'Betreff
.BodyFormat = 2 '2 = HTML, 1 = Text
.Attachments.Add strDatei 'Anhang
.HTMLBody = strBodyText & strSignature
End With
'** Erzeugte Datei schließen
Workbooks(Dir(strDatei)).Close
'** Erzeugte Datei wieder löschen
Kill (strDatei)
Worksheets("Protokoll").Visible = False
Worksheets("Ausfüllhilfe").Activate
'** E-Mail anzeigen
Mail.Display
'Abspeichern
Worksheets("Ausfüllhilfe").Activate
If Dir(Range("B56"), vbDirectory) = "" Then
MkDir (Range("B57"))
End If
If Dir(Range("B58"), vbDirectory) = "" Then
MkDir (Range("B59"))
End If
Worksheets("Protokoll").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Range("H61"), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
Exit Sub
End If
'**Szenario 2= Material entstanden, dann ausdrucken und per Mail ?
Else
Worksheets("Ausfüllhilfe").Activate
Sheets("Ausfüllhilfe").Unprotect
Range("H4") = "Verwaltet!"
Sheets("Ausfüllhilfe").Protect
Worksheets("Protokoll").Activate
Sheets("Protokoll").Unprotect
Range("A37") = "BLABLABLA" & Range("H47").Value
'** Einfärbung der Zellen B 1
If Range("B21") = "" And Range("C21") = "" Then
Range("B20:C21").Interior.Color = vbBlack
ElseIf Range("B21") = "x" Then
Range("C20:C21").Interior.Color = vbBlack
ElseIf Range("C21") = "x" Then
Range("B20:B21").Interior.Color = vbBlack
'** Einfärbung Zellen B 2
If Range("D21") = "" And Range("C21") = "" Then
Range("D20:E21").Interior.Color = vbBlack
ElseIf Range("D21") = "x" Then
Range("E20:E21").Interior.Color = vbBlack
ElseIf Range("E21") = "x" Then
Range("D20:D21").Interior.Color = vbBlack
'** Einfärben Zellen B3
If Range("F21") = "" And Range("C21") = "" Then
Range("F20:G21").Interior.Color = vbBlack
ElseIf Range("F21") = "x" Then
Range("G20:G21").Interior.Color = vbBlack
ElseIf Range("G21") = "x" Then
Range("F20:F21").Interior.Color = vbBlack
'** Einfärben Zellen B 4
If Range("H21") = "" And Range("C21") = "" Then
Range("H20:I21").Interior.Color = vbBlack
ElseIf Range("H21") = "x" Then
Range("I20:I21").Interior.Color = vbBlack
ElseIf Range("I21") = "x" Then
Range("H20:H21").Interior.Color = vbBlack
Worksheets("Protokoll").Protect
End If
'** Das aktive Tabellenblatt wird über Outlook versendet
'** Dimensionierung der Variablen
Worksheets("Protokoll").Activate
Set outObj = CreateObject("Outlook.Application")
Set Mail = outObj.CreateItem(0)
'** Pfad für temporäre Zwischenspeicherung angeben
strPfad = "C:\Temp" 'entsprechend anpassen
'** Aktuelles aktives Blatt in neue Arbeitsmappe kopieren
strBlatt = ActiveSheet.Name
'** Gewähltes Tabellenblatt kopieren
Sheets(strBlatt).Copy
'** Blatt temporär in vorgegebenes Verzeichnis abspeichern
ActiveWorkbook.SaveAs strPfad & "\" & ActiveSheet.Name, FileFormat:=xlOpenXMLWorkbookMacroEnabled
'** Pfad und Dateiname der neuen Datei zwischenspeichern
strDatei = ActiveWorkbook.FullName
'** Betreff-Text festlegen
strSubjectText = "? " & Range("B11").Value
'** Nachrichten-Text festlegen
strBodyText = "" & "Sehr geehrte Damen und Herren,
" & _
"anbei übersende ich Ihnen BLABLALBA
" & _
"Mit freundlichen Grüßen.
" & _
"gez. " & Range("B18").Value & "
" & _
Range("A42").Value & "
"
'** Mail erzeugen
With Mail
.To = Range("A43") 'Empfänger
.Subject = strSubjectText 'Betreff
.BodyFormat = 2 '2 = HTML, 1 = Text
.Attachments.Add strDatei 'Anhang
.HTMLBody = strBodyText & strSignature
End With
'** Erzeugte Datei schließen
Workbooks(Dir(strDatei)).Close
'** Erzeugte Datei wieder löschen
Kill (strDatei)
'** E-Mail anzeigen
Mail.Display
'** Datei drucken per Druckerauswahl
Dim strPrinterName As String
Dim varRueckgabe As Variant
strPrinterName = Application.ActivePrinter
varRueckgabe = Application.Dialogs(xlDialogPrinterSetup).Show
If varRueckgabe = "Falsch" Then
Exit Sub
End If
ActiveSheet.PrintOut
Application.ActivePrinter = strPrinterName
Worksheets("Protokoll").Visible = False
Worksheets("Ausfüllhilfe").Activate
' Abspeichern
If Dir(Range("B56"), vbDirectory) = "" Then
MkDir (Range("B57"))
End If
If Dir(Range("B58"), vbDirectory) = "" Then
MkDir (Range("B59"))
End If
Worksheets("Protokoll").Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Range("H61"), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
Exit Sub
End If
End Sub