per Hyperlink Zelle in eine andere Zelle übertragen

[Rabe]

Hi Stefan,

ich habe mal Deine Lösung mit dem einzelnen Makro in die bestehende Datei (siehe Anhang) eingebaut. Die gefällt mir seeeehr gut. Nur die Farben stimmen nicht ganz überein.


  Personaleinsatz - Steffl.xlsb (Größe: 63,4 KB / Downloads: 3)

[Steffl]

Hallo Ralf,

.... Nur die Farben stimmen nicht ganz überein.

da habe ich auch geschummelt, weil sich die Makros bei Logi doch zu den anderen Makros unterscheiden, habe ich hier einfach mal 'angepasst'. Mit xlThemeColorAccent6 anstelle von xlThemeColorAccent1 sieht es aber besser aus.

[Rabe]

Hi Stefan,

:100:

jetzt fehlt nur noch das Summieren in den Spalte EA-EF. :21:

[Steffl]

Hallo Ralf,

jetzt fehlt nur noch das Summieren in den Spalte EA-EF.

tja, wenn das so einfach wäre  :s  Irgendwie hat es immer nicht funktioniert die letzten beiden Werte (0,5 und 0,25) hat er nicht berechnet. Als letzten Ausweg habe ich die Werte bei TintAndShade verkürzt. Ich sehe keinen großen farblichen Unterschied. Bisher war die Zeile so

Code:

 vntFarben = Array(-0.249977111117893, 0, 0.399975585192419, 0.599993896298105)

Du siehst im Code, wie ich sie geändert habe. Da hat es dann funktioniert. In der Datei vom TE muss noch in den Summierungsspalten das Format angepasst werden.

Code:

Sub prcFarben()
  Dim lngC As Long, LngA As Long, lngB As Long
  Dim sngWert As Single
  Dim vntFarben As Variant
  Dim vntTheme As Variant
  Dim vntWert As Variant
  Dim vntAuswahl As Variant
 
 
  vntWert = Array(1, 0.75, 0.5, 0.25)
  vntFarben = Array(-0.25, 0, 0.4, 0.6)
  vntAuswahl = Array("L", "K", "W", "C", "F")
 
  Select Case Left(ActiveSheet.Shapes(Application.Caller).DrawingObject.Characters.Text, 1)
     Case vntAuswahl(4)
        vntTheme = xlThemeColorAccent2
     Case vntAuswahl(3)
        vntTheme = xlThemeColorAccent3
     Case vntAuswahl(0)
        vntTheme = xlThemeColorAccent6
     Case vntAuswahl(2)
        vntTheme = xlThemeColorAccent4
     Case vntAuswahl(1)
        vntTheme = xlThemeColorAccent5
  End Select
 
  With ActiveCell
     .Value = Left(ActiveSheet.Shapes(Application.Caller).DrawingObject.Characters.Text, 1)
     With .Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = vntTheme
        .TintAndShade = vntFarben(WorksheetFunction.Match _
         (CDbl(Mid(ActiveSheet.Shapes(Application.Caller).DrawingObject.Characters.Text, 2)), vntWert, 0) - 1)
        .PatternTintAndShade = 0
     End With
     
     For LngA = 0 To UBound(vntAuswahl)
        For lngC = 2 To 129
           For lngB = 0 To UBound(vntFarben)
              With Cells(ActiveCell.Row, lngC)
                 If .Value = vntAuswahl(LngA) And WorksheetFunction.Match(Round(.Interior.TintAndShade, 2), vntFarben, 1) - 1 = lngB Then
                    sngWert = sngWert + 1 - 1 * lngB / 4
                    Exit For
                 End If
              End With
           Next lngB
        Next lngC
        Cells(ActiveCell.Row, 131).Offset(, LngA) = sngWert
        sngWert = 0
     Next LngA
  End With
End Sub

[Rabe]

Hi Stefan,

ja, so sieht es gut aus und es rechnet richtig:

  Personaleinsatz - Steffl V2.xlsb (Größe: 62,37 KB / Downloads: 3)

[Serdinho]

Hallo zusammen,

wow vielen lieben Dank. Finde es klasse, wie ihr behilflich seid! Ihr habt mir wirklich sehr geholfen. Genau so wollte ich es haben.

Danke danke danke!!!! :18: