VBA Excel2010 condicional formating

Hallo Sonja,

es ist kein Problem den Blattschutz mit der Anlage eines neuen Blatts zu gestalten. Wenn du in einem VBA-Projekt mit geschützten Blättern arbeiten willst, dann ist es sinnvoll, die entsprechenden Makros in einem eigenen Modul des Projekts anzulegen. Diese Makros kann man dann von überall im VBA-Projekt aufrufen.

Da du sehr große Zellbereiche bearbeiten willst ist ratsam auch gleich eine Fixierung des Fensters der neuen Datei einzubauen.

In meinem Beispiel zu den Hyperlinks baust du dann die Zeile ein um das Blatt zu schützen:

 'Neues Blatt umbenennen und Daten eintragen
 With wksNeu
 .Name = strTabName
 'nachfolgend Eingaben im neuen Blatt nur zum Testen
 .Cells(2, 1).Value = "Produkt"
 .Cells(2, 2).Value = "Volumen"
 .Cells(2, 3).Value = "Material"
 .Cells(3, 1).Value = Me.TextBox1
 .Cells(3, 2).Value = Me.TB2
 .Cells(3, 3).Value = Me.TB3
 End With 'wksNeu
 'Blatt schützen
 Call BlattSchutz\_EIN\_Neu(wks:=wksNeu, PW:=True)
 'Daten in Produktliste eintragen

Wenn du mit festen Kennwörtern im Code arbeitest, dann muss du auch das VBA-Projekt per Kennwort schützen, sonst kann jeder den Code einsehen.

Gruß
Franz

'Code zum Blattschutz in einem allgemeinen Modul
Option Explicit
Private Const BlattKW = "MeinpassWort" 'Kennwort ggf. anpassen

Sub BlattSchutz\_EIN\_Neu(wks As Worksheet, Optional PW As Boolean)
 'Blattschutz für neues Blatt einrichten-inkl. Fensterfixierung
 Dim strPW As String
 With wks
 'Zellbereiche: Schutz aufheben
 .Range("A31:ECA38,A75:ECA83").Locked = False
 'Tabellenblatt fixieren, falls Zustand = nicht fixiert.
 With ActiveWindow
 If .FreezePanes = False Then
 .ScrollColumn = 1
 .ScrollRow = 1
 Range("B5").Select 'Zelle für Fenster-Fixierung ggf. anpassen
 .FreezePanes = True
 End If
 End With
 'Blatt schützen
 .Protect Password:=IIf(PW = True, BlattKW, ""), DrawingObjects:=True, \_
 Contents:=True, Scenarios:=True
 .EnableSelection = xlNoRestrictions
 Range("A31").Select
 End With
End Sub

Sub BlattSchutz\_EIN(wks As Worksheet, Optional PW As Boolean)
 'Blatt schützen
 With wks
 .Protect Password:=IIf(PW = True, BlattKW, ""), DrawingObjects:=True, \_
 Contents:=True, Scenarios:=True
 .EnableSelection = xlNoRestrictions
 End With
End Sub

Sub BlattSchutz\_AUS(wks As Worksheet, Optional PW As Boolean)
 'Blattschutz aufheben
 If PW = True Then
 wks.Unprotect Password:=BlattKW
 Else
 wks.Unprotect
 End If
End Sub


'Admin-Makros für Blattschutz-Aktionen
'Diese müssen ggf. direkt aus dem VBA-Editor gestartet werden \_
 - sie sind im Makro-Start-Dialog nicht verfügbar
Private Sub AktivesBlatt\_Schutzaus()
 Call BlattSchutz\_AUS(wks:=ActiveSheet, PW:=True)
End Sub

Private Sub AktivesBlatt\_Schutzein()
 Call BlattSchutz\_EIN(wks:=ActiveSheet, PW:=True)
End Sub

Private Sub AktivesBlatt\_Schutzein\_NEU()
 'Makro um Blattschutz für aktives Tabellenblatt nachträglich einzurichten wie für neues Blatt
 Call BlattSchutz\_EIN\_Neu(wks:=ActiveSheet, PW:=True)
End Sub

Hallo Franz,

eine Frage, ich habe es jetzt glaube ich soweit hergebracht den Code für mich abzuwandeln, was aber immer noch nicht funktioniert, ist das ich mit einem Userform diesen geschützen Bereich trotzdem noch beschreiben kann.
Ich möchte den Bereich deswegen schützen, weil Mitarbeiter von Hand dort keine Nachtragungen machen können sollen, ausser ich weiss davon - sprich, sie müssen mich holen, weil nur ich das Passwort habe und weiss wie’s funktioniert…
Die Mitarbeiter sollen den Bereich nur per Userform bearbeiten können (also nur einmalige Einträge machen können)…

Liebe Grüße,
Sonja

Hallo Sonja,

die entsprechende Aktion muss du in das Makro/die Makros einbauen, das/die Userformdaten in die Tabelle(n) schreiben.
Dazu muss das Makro nach dem Eintragen von Daten den Schutz des Eingabeblattes erst aufheben und dann den relevanten Zellbereich nach ungeschützen Zellen mit Inhalt durchsuchen und jeweils den Zellschutz aktivieren.
Nach der Prüfung muss der Blattschutz wieder aktiviert werden.

Damit das Ganze rund läuft muss zusätzlich eine Fehlerbehandlung eingebaut werden, die eine spezielle Meldung ausgeben sollte beim Versuch eine geschützte Zelle zu überschreiben.

Gruß
Franz

Beispielmakro

Private Sub cmb\_Eintragen\_Click()
 Dim Zeile As Long, Spalte As Long, wks As Worksheet, Zelle As Range
 On Error GoTo Fehler
 Set wks = ActiveSheet 'Tabellenblatt in das Daten eingegeben werden sollen
 'Eingabezeile ermitteln/setzen
 Zeile = ActiveCell.Row
 'Muss-Eingaben prüfen
 If Me.TextBox\_A "" Or wks.Cells(Zeile, 1) "" Then
 With wks
'Daten eintragen in Spalten der Zeile
 For Spalte = 1 To 175
 With .Cells(Zeile, Spalte)
 Select Case Spalte
 Case 1
 .Value = Me.TextBox\_A.Value
 Case 3
 If Me.TextBox\_C "" Then
 .Value = Me.TextBox\_C.Value
 .Offset(0, -1).FormulaR1C1 = "=IF(RC[1]=""A"",100,50)"
 End If
 Case 4
 If Me.TextBox\_D "" Then .Value = Me.TextBox\_D.Value
 Case 10 To 175
 .Value = Spalte
 End Select
 End With
NextItem:
 Next

'Zellen mit eingetragenen Inhalten sperren - den zu prüfenden Bereich muss man \_
 ggf. an den Bereich anpassen in den mit dem Userform jeweils Daten eingetragen werden. \_
 evtl. muss man auch in mehren Schleifen mehrere Bereiche abarbeiten
 Call BlattSchutz\_AUS(wks:=wks, PW:=True)
 For Each Zelle In .Range(.Cells(Zeile, 1), .Cells(Zeile, 175)).Cells
 With Zelle
 If .Locked = False And Not IsEmpty(Zelle) Then .Locked = True
 End With
 Next
 Call BlattSchutz\_EIN(wks:=wks, PW:=True)
 End With
 Else
 MsgBox "Eingabewert für Spalte A fehlt!", vbInformation + vbOKOnly, \_
 "Eingabewerte in Tabelle eintagen"
 End If

 'Fehlerbehandlung
 Err.Clear
Fehler:
 With Err
 Select Case .Number
 Case 0 ' Alles ist OK
 Case 1004
 If MsgBox("Wert konnte in Zelle """ & wks.Cells(Zeile, Spalte).Address \_
 & """ nicht eingetragen werden, da schon Wert vorhanden." & vbLf & vbLf \_
 & "Bitte rufe Sonja (Tel. 1234) an, wenn der Wert geändert werden soll.", \_
 vbRetryCancel, \_
 "Eintragen Daten - Zelle hat schon Inhalt") = vbRetry Then Resume NextItem
 Case Else
 MsgBox "Fehler-Nr.; " & .Number & vbLf & .Description
 End Select
 End With
 Application.DisplayAlerts = True
End Sub

Vielen lieben Dank für deine grossartige Hilfe!!
Ich habe meinen Fehler herausgefunden!! =)

Was ich jetzt noch am Suchen bin: ich habe ein Diagramm in der Größe D40:K50 mit den Daten von D21:K21 und D23:K23 (alles perfekt formatiert).
Jetzt möchte ich, dass ich per knopfdruck jeden Tag ein neues Diagramm hinzufügen kann, d.h. ich möchte es also kopieren und direkt daneben (in L40:S50 usw.) einfügen, mit den Daten L21:S21 und L23:S23 usw.
Ist sowas möglich, dass es mir das immer wieder kopiert mit den neuen Daten und einfach daneben einfügt? Da zerbreche ich mir auch schon lange den Kopf!!

Ich hoffe du kannst mir da auch noch helfen!!

Liebe Grüße,
Sonja

Hallo Sonja,

Programmierungen rund um Diagramme sind immer wieder eine Herausforderung, da das Objektmodel komplex und die Zahl der Varianten so groß ist.

Ich bin jetzt davon ausgegangen, dass das Diagramm eine Datenreihe hat. Den Abschnitt in dem den Datenreihen die Werte zugewiesen werden muss du also ggf. noch anpassen.
Der Code passt hier für Säulen- und Liniendiagramme bei anderen Diagrammtypen kann es Abweichungen geben. ggf. muss du mal das Anpassen der Datenbereiche mit dem Recorder aufzeichnen, um die Syntax hinzubekommen.

Gruß
Franz

Sub Chart\_kopieren()
'
' Chart\_kopieren Makro
'
 Dim objChartObject As ChartObject, objChart As Chart, objReihe As Series
 Dim objShape As Shape
 Dim wks As Worksheet
 Dim rngZiel As Variant
 Dim DeltaX As Double, DeltaY As Double

 Const Spalte\_1\_Chart = 4 'Spalte D - Spalte der linkenoberen Ecke des 1. Diagramms
 Const SpaltenChart = 8 'Anzahl Spalten von Chart zu Chart
 Const ZeileChart = 40 'Zeile in der Charts angeordnet werden
 Const Zeile\_X = 21 'Zeile mit den X-Werten der Datenreihe(n)
 Const Zeile\_Y = 23 'Zeile mit den Y-Werten der Datenreihe(n)

 On Error GoTo Fehler
 Set wks = ActiveSheet
 With wks
 'letztes Diagramm-Objekt im Blatt Objektvariablen zuordnen
 Set objChartObject = .ChartObjects(.ChartObjects.Count)
 Set objChart = objChartObject.Chart
 Set objShape = .Shapes(objChartObject.Name)

 With objShape
 'Position des Shapes relativ zur Einfügezelle merken
 DeltaX = .Left - .TopLeftCell.Left
 DeltaY = .Top - .TopLeftCell.Top

 'neue Zielzelle ermitteln
 Set rngZiel = .TopLeftCell.Offset(0, SpaltenChart)
 rngZiel.Select
 End With

 'Einfügezelle bestätigen/anpassen
 Set rngZiel = Application.InputBox(Prompt:="Diagramm in Zelle kopieren? (ggf. Auswahl ändern)", \_
 Title:="Diagramm kopieren", Default:=rngZiel.Address, Type:=8)
 'Zeile und Spalte der gewählten Zelle prüfen
 If rngZiel.Row ZeileChart Then
 MsgBox "Für Diagramm soll eine Zelle in Zeile " & ZeileChart & " gewählt werden!"
 GoTo Fehler
 End If
 If rngZiel.Column Mod SpaltenChart Spalte\_1\_Chart Then
 MsgBox "Für Diagramm soll Spalte in vielfachen von " & SpaltenChart \_
 & " relativ zu Spalte D gewählt werden (D, L, T, AB, AJ, usw.!"
 GoTo Fehler
 End If

 rngZiel.Select
 'Diagramm kopieren
 objShape.Copy
 ActiveSheet.Paste

 'Objekte für neues Diagramm setzen
 Set objChartObject = .ChartObjects(.ChartObjects.Count)
 Set objChart = objChartObject.Chart
 Set objShape = .Shapes(objChartObject.Name)
 'Diagramm genau positionieren
 With objShape
 .Left = rngZiel.Left + DeltaX
 .Top = rngZiel.Top + DeltaY
 End With

 'Datenbereiche der/den Datenreihen neu zuordnen
 Set objReihe = objChart.SeriesCollection(1)
 objReihe.Name = "='" & .Name & "'!" & .Cells(Zeile\_X - 1, rngZiel.Column).Address
 objReihe.XValues = "='" & .Name & "'!" & .Range(.Cells(Zeile\_X, rngZiel.Column), \_
 .Cells(Zeile\_X, rngZiel.Column + SpaltenChart - 1)).Address
 objReihe.Values = "='" & .Name & "'!" & .Range(.Cells(Zeile\_Y, rngZiel.Column), \_
 .Cells(Zeile\_Y, rngZiel.Column + SpaltenChart - 1)).Address
 End With
Fehler:
 With Err
 Select Case .Number
 Case 0 'alles OK
 Case 13 'wird ausgelöst wenn Zellauswahl abgebrochen wird
 'do nothing
 Case Else
 MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
 End Select
 End With
 Set objChartObject = Nothing: Set objChart = Nothing: Set objReihe = Nothing
 Set objShape = Nothing: Set wks = Nothing: Set rngZiel = Nothing
End Sub

Hallo Franz,

ja das stimmt. Diagramme sind eine Herausforderung!!
Leider bringt mir Dein Code immer wieder Fehlermeldungen. Zudem möchte ich eigentlich keine Abfragen.
Ist es nicht mölich, dass es mir die Diagramm immer automatisch in die nächste entsprechende (+8) Zelle stellt?
Es soll einfach automatisch, per Knopfdruck das alte Diagramm kopieren und in die nächste freie Positioin kopieren und einfach die Quelle anpassen.
Als Name des Diagramms würde sich z.B. das Datum anbieten, damit es sich auch ändert und man sie unterscheiden kann…

Ich habe jetzt an Deinem Code so herumgebastelt, aber leider komme ich auf keinen grünen Zweig…
Kannst Du mir bitte nochmal helfen?

Liebe Grüße,
Sonja