Office: WENN Makro

EarlFred · 16. Dezember 2020

basierend auf Beitrag #26 sind die Änderungen gering:
Code:

Option Explicit

Private Enum eForm
ellipse = msoShapeOval
dreieck = msoShapeIsoscelesTriangle
viereck = msoShapeRectangle
End Enum

Private Type tÜberwachungsbereiche
rngIntersect As Range
Form As eForm
End Type

Private Type tFormParams
Form As eForm
oForm As Shape
TargeWS As Worksheet
Versatz As Long
Oben As Single
Links As Single
Höhe As Single
Breite As Single
FillVisible As Long
FillForeColorRGB As Long
LineWeight As Single
LineForeColorRGB As Long
Flip As Long
Rotation As Long
Valid As Boolean
End Type

Private Sub Worksheet_Change(ByVal Target As Range)

'################################################################################################
'################################################################################################
'Adressbereiche definieren
Call PrüfeSymbol(rng1:=Target, rng2:=Union(Me.Range("milestones_input"), Me.Range("deliverables_input"), Me.Range("meetings_input")))
'################################################################################################
'################################################################################################

End Sub

Private Function LetParams(ByRef rngAnker As Range, ByRef lngForm As eForm, ByRef lngVersatz As Long) As tFormParams
Dim ParamsTemp As tFormParams
ParamsTemp = LetDefaultParams()

ParamsTemp.Versatz = -((rngAnker.Column - Range("anchor_cell").Column) - (lngVersatz * 4))
If rngAnker.Column + ParamsTemp.Versatz > 0 And rngAnker.Value "" Then

ParamsTemp.Valid = True
ParamsTemp.Form = lngForm
Set ParamsTemp.TargeWS = rngAnker.Worksheet

'################################################################################################
'################################################################################################
'Im Select-Block die individuellen (vom Default abweichenden) Eigenschaften der Formen festlegen

Select Case ParamsTemp.Form

Case eForm.ellipse
ParamsTemp.Höhe = 14
ParamsTemp.Breite = 13
ParamsTemp.Oben = rngAnker.Top + 3
ParamsTemp.Links = Application.Max(rngAnker.Offset(0, ParamsTemp.Versatz).Left - (ParamsTemp.Breite / 2), 0)

Case eForm.dreieck
ParamsTemp.Höhe = 13
ParamsTemp.Breite = 14
ParamsTemp.Oben = rngAnker.Top + ParamsTemp.Höhe / 3
ParamsTemp.Links = Application.Max(rngAnker.Offset(0, ParamsTemp.Versatz).Left - 7, 0)

Case eForm.viereck
ParamsTemp.Höhe = 9
ParamsTemp.Breite = 9
ParamsTemp.Oben = rngAnker.Top + ParamsTemp.Höhe / 1.5
ParamsTemp.Links = Application.Max(rngAnker.Offset(0, ParamsTemp.Versatz).Left - 4, 0)
ParamsTemp.LineWeight = 4.5
ParamsTemp.Rotation = 45
End Select

'################################################################################################
'################################################################################################
End If

LetParams = ParamsTemp

End Function

Private Function LetDefaultParams() As tFormParams
Dim ParamsTemp As tFormParams

With ParamsTemp
.FillVisible = msoTrue
.FillForeColorRGB = RGB(248, 248, 248)
.LineForeColorRGB = RGB(0, 90, 175)
.LineWeight = 4
.Rotation = 0
.Flip = -1
.Valid = False
End With

LetDefaultParams = ParamsTemp
End Function

Private Function PrüfeSymbol(ByRef rng1 As Range, ByRef rng2 As Range) As Boolean
Dim rngAktuell As Range
Dim rngIntersect As Range

Dim Versatz As Long
Dim Form As eForm

Set rngIntersect = Intersect(rng1, rng2)
If Not rngIntersect Is Nothing Then
For Each rngAktuell In rngIntersect
If rngAktuell.Value "" Then
Select Case Left$(rngAktuell.Value, 1)
Case "k"
Form = eForm.ellipse
Case "d"
Form = eForm.dreieck
Case "v"
Form = eForm.viereck
Case Else
Call MsgBox(Prompt:="Unbekannte Form '" & Left$(rngAktuell.Value, 1) & "'", Buttons:=vbOKOnly + vbCritical, Title:="Unbekannte Form")
PrüfeSymbol = False
Exit Function
End Select

If IsNumeric(Mid(rngAktuell.Value, 2, 99)) Then
Versatz = CLng(Mid(rngAktuell.Value, 2, 99))
Else
Call MsgBox(Prompt:="Ungültiger Wert für den Versatz!", Buttons:=vbOKOnly + vbCritical, Title:="Ungültiger Versatz")
PrüfeSymbol = False
Exit Function
End If

Call ZeichneForm(FormParams:=LetParams(rngAnker:=rngAktuell, lngForm:=Form, lngVersatz:=Versatz))
End If
Next rngAktuell
End If

PrüfeSymbol = (Err = 0)
End Function

Private Function ZeichneForm(ByRef FormParams As tFormParams)

If FormParams.Valid Then
Set FormParams.oForm = FormParams.TargeWS.Shapes.AddShape( _
Type:=FormParams.Form, _
Left:=FormParams.Links, _
Top:=FormParams.Oben, _
Width:=FormParams.Breite, _
Height:=FormParams.Höhe)
With FormParams.oForm
.Fill.Visible = FormParams.FillVisible
.Fill.ForeColor.RGB = FormParams.FillForeColorRGB
.Line.ForeColor.RGB = FormParams.LineForeColorRGB
.Line.Weight = FormParams.LineWeight
.Rotation = FormParams.Rotation
If FormParams.Flip > -1 Then Call .Flip(FormParams.Flip)
End With

End If
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Die verwendeten Formkurzzeichen findest du im Code.

falko_d · 16. Dezember 2020

Wow das ist wirklich glorreich! Tausend Dank!

Spende an GiveWell geht heute Abend raus!

Nun fällt es mir noch schwer die Bereiche zu trennen. Würde gern weiterhin ohne v / k / d arbeiten, in den Bereichen "milestones_input" "deliverables_input" und "meetings_input". Nur bei "symbol_input" die Buchstaben benutzen.

Ich dachte das kann ich in PrüfeSymbol ändern, indem ich weitere Cases hinzufüge. z.B.
Case Intersect(rng1, Me.Range("milestones_input"))
Form = eForm.ellipse
...

das passt aber nicht unter Select Case Left$(rngAktuell.Value, 1).

Hast du mir da noch nen Tipp dafür?

Vielen, vielen Dank schonmal!

EarlFred · 16. Dezember 2020

Danke für die Spende.

Dennoch: Mir wird das Thema fad, daher letzte Hilfe meinerseits zu neuen Ideen. Nutze die Feiertage, um den Code zu verstehen, damit du ihn selbst weiterentwickeln kannst. Mit F8 und wachen Augen ist das kein Hexenwerk.

Code:

Option Explicit

Private Enum eForm
ellipse = msoShapeOval
dreieck = msoShapeIsoscelesTriangle
viereck = msoShapeRectangle
Variabel = 0
End Enum

Private Type tÜberwachungsbereiche
rngIntersect As Range
Form As eForm
End Type

Private Type tFormParams
Form As eForm
oForm As Shape
TargeWS As Worksheet
Versatz As Long
Oben As Single
Links As Single
Höhe As Single
Breite As Single
FillVisible As Long
FillForeColorRGB As Long
LineWeight As Single
LineForeColorRGB As Long
Flip As Long
Rotation As Long
Valid As Boolean
End Type

Private Sub Worksheet_Change(ByVal Target As Range)

'################################################################################################
'################################################################################################
'Adressbereiche und Formen definieren
Call PrüfeSymbol(rng1:=Target, rng2:=Me.Range("milestones_input"), Form:=eForm.ellipse)
Call PrüfeSymbol(rng1:=Target, rng2:=Me.Range("deliverables_input"), Form:=eForm.dreieck)
Call PrüfeSymbol(rng1:=Target, rng2:=Me.Range("meetings_input"), Form:=eForm.viereck)
Call PrüfeSymbol(rng1:=Target, rng2:=Me.Range("variabler_input"), Form:=eForm.Variabel)
'################################################################################################
'################################################################################################
'################################################################################################
'################################################################################################

End Sub

Private Function LetParams(ByRef rngAnker As Range, ByRef lngForm As eForm, ByRef lngVersatz As Long) As tFormParams
Dim ParamsTemp As tFormParams
ParamsTemp = LetDefaultParams()

ParamsTemp.Versatz = -((rngAnker.Column - Range("anchor_cell").Column) - (lngVersatz * 4))
If rngAnker.Column + ParamsTemp.Versatz > 0 And rngAnker.Value "" Then

ParamsTemp.Valid = True
ParamsTemp.Form = lngForm
Set ParamsTemp.TargeWS = rngAnker.Worksheet

'################################################################################################
'################################################################################################
'Im Select-Block die individuellen (vom Default abweichenden) Eigenschaften der Formen festlegen

Select Case ParamsTemp.Form

Case eForm.ellipse
ParamsTemp.Höhe = 14
ParamsTemp.Breite = 13
ParamsTemp.Oben = rngAnker.Top + 3
ParamsTemp.Links = Application.Max(rngAnker.Offset(0, ParamsTemp.Versatz).Left - (ParamsTemp.Breite / 2), 0)

Case eForm.dreieck
ParamsTemp.Höhe = 13
ParamsTemp.Breite = 14
ParamsTemp.Oben = rngAnker.Top + ParamsTemp.Höhe / 3
ParamsTemp.Links = Application.Max(rngAnker.Offset(0, ParamsTemp.Versatz).Left - 7, 0)

Case eForm.viereck
ParamsTemp.Höhe = 9
ParamsTemp.Breite = 9
ParamsTemp.Oben = rngAnker.Top + ParamsTemp.Höhe / 1.5
ParamsTemp.Links = Application.Max(rngAnker.Offset(0, ParamsTemp.Versatz).Left - 4, 0)
ParamsTemp.LineWeight = 4.5
ParamsTemp.Rotation = 45
End Select

'################################################################################################
'################################################################################################
End If

LetParams = ParamsTemp

End Function

Private Function LetDefaultParams() As tFormParams
Dim ParamsTemp As tFormParams

With ParamsTemp
.FillVisible = msoTrue
.FillForeColorRGB = RGB(248, 248, 248)
.LineForeColorRGB = RGB(0, 90, 175)
.LineWeight = 4
.Rotation = 0
.Flip = -1
.Valid = False
End With

LetDefaultParams = ParamsTemp
End Function

Private Function PrüfeSymbol(ByRef rng1 As Range, ByRef rng2 As Range, ByRef Form As eForm) As Boolean
Dim rngAktuell As Range
Dim rngIntersect As Range
Dim Versatz As Long

Set rngIntersect = Intersect(rng1, rng2)
If Not rngIntersect Is Nothing Then
For Each rngAktuell In rngIntersect
If rngAktuell.Value "" Then

If Form = eForm.Variabel Then
Select Case Left$(rngAktuell.Value, 1)
Case "k"
Form = eForm.ellipse
Case "d"
Form = eForm.dreieck
Case "v"
Form = eForm.viereck
Case Else
Call MsgBox(Prompt:="In diesem Bereich ist eine Formeingabe erforderlich." & vbLf & vbLf & "Erlaubte Werte: {k;d;v}", Buttons:=vbOKOnly + vbCritical, Title:="Unbekannte Form '" & Left$(rngAktuell.Value, 1) & "'")
PrüfeSymbol = False
Exit Function
End Select

If IsNumeric(Mid(rngAktuell.Value, 2, 99)) Then
Versatz = CLng(Mid(rngAktuell.Value, 2, 99))
Else
Call MsgBox(Prompt:="Ungültiger Wert für den Versatz!", Buttons:=vbOKOnly + vbCritical, Title:="Ungültiger Versatz")
PrüfeSymbol = False
Exit Function
End If
Else
If IsNumeric(rngAktuell.Value) Then
Versatz = rngAktuell.Value
Else
Call MsgBox(Prompt:="In diesem Bereich ist keine Formangabe erlaubt!", Buttons:=vbOKOnly + vbCritical, Title:="Ungültige Eingabe")
PrüfeSymbol = False
Exit Function
End If
End If

Call ZeichneForm(FormParams:=LetParams(rngAnker:=rngAktuell, lngForm:=Form, lngVersatz:=Versatz))
End If
Next rngAktuell
End If

PrüfeSymbol = (Err = 0)
End Function

Private Function ZeichneForm(ByRef FormParams As tFormParams)

If FormParams.Valid Then
Set FormParams.oForm = FormParams.TargeWS.Shapes.AddShape( _
Type:=FormParams.Form, _
Left:=FormParams.Links, _
Top:=FormParams.Oben, _
Width:=FormParams.Breite, _
Height:=FormParams.Höhe)
With FormParams.oForm
.Fill.Visible = FormParams.FillVisible
.Fill.ForeColor.RGB = FormParams.FillForeColorRGB
.Line.ForeColor.RGB = FormParams.LineForeColorRGB
.Line.Weight = FormParams.LineWeight
.Rotation = FormParams.Rotation
If FormParams.Flip > -1 Then Call .Flip(FormParams.Flip)
End With

End If
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

falko_d · 5. Januar 2021

Hallo EarlFred und frohes Neues noch.

Mein Arbeitslaptop wurde neu aufgesetzt über die Feiertage & nun habe ich MS Office 365 drauf.

Das Makro macht nun nicht mehr ganz mit.

Die Formen sind teils verzogen und kommen nicht mehr an der richtigen Stelle raus. Der Versatz stimmt aber die Position in der Zelle stimmt nicht.

Ich klemme mich schon dahinter, versuche FormParams anzupassen, bin mir aber nicht sicher ob ich es gelöst bekomme.

Gruß
Falko

falko_d · 5. Januar 2021

Mit F8 zeigt sich, dass die Form der Ellipse sich bei Rotation und Flip zu ändern scheint. Diese sind aber beide 0 an dieser Stelle.

Der Versatz bzw die Position ändert sich mit Bezug auf die Zahl die ich eingebe. Die Symbole tauchen nicht mehr mittig auf dem Zellenrahmen auf. Selbst wenn ich sie passend einstelle (bei .Oben und .Links) verschieben sie sich leicht, je nach dem welche Zahl eingegeben wird.

Komme nun leider nicht weiter. Hast du mir evtl einen Tipp? :/

Office: WENN Makro

WENN Makro

WENN Makro

WENN Makro

WENN Makro - Similar Threads - Makro

Makro Zip-Datei von Webseite runterladen, auspacken, kopieren

Makro für variable Anzahl von Datensätzen

Makro aus personal.xls starten

Dokumente und Blatt umbenennen

Speichern mit dem Titel der Zelle A2

Barcode Scanliste Makro anpassen

Makro wird nicht angezeigt im Makro Auswahlfenster