Format einer Zelle auf ein Textfeld übertragen

[Hardbopper]

siehe Anhang:


Der Zellinhalt von A3 ist bedingt formatiert (Schriftfarbe grün, wenn TEIL(A3;5;3)>0)

Wie kann dieses Format auf den Wert im Textfeld (F2:G5) übertragen werden ?

Hardbopper


  Übertragung eines Zellformats auf ein Textfeld.xlsx (Größe: 10,65 KB / Downloads: 10)

[schauan]

Hallöchen,

reicht Dir als Ansatz schon

ActiveCell.DisplayFormat.Interior.Color

[chris-ka]

Hi,

zu =TEIL(A3;5;3)>0
?
wann wird den das Ergebnis nicht Grün?

die Formel ergibt (für mich jedenfalls ) keinen Sinn..

[Klaus-Dieter]

Hallo,


ha so etwas noch nie versucht, gehe aber davon aus, dass man ein Textfeld nicht mit bedingter Formatierung verändern kann.

[Case]

Hallo, :19:

bezogen auf deine Beispieldatei: :21:

Code:

Tabelle1.Shapes(1).TextFrame.Characters.Font.Color = Tabelle1.Range("A3").DisplayFormat.Font.Color

Wenn du das über "Private Sub Worksheet_Calculate()" machst, kannst du beide "Tabelle1." rauslöschen.

Hast du mehrere Textfelder, dann arbeite mit dem richtigen Index, oder dem Namen des entsprechenden Textfeldes.

[Hardbopper]

Hallo Chris-ka,

Die Formel in A3 enthält auch Textteile. Für die bedingte Formatierung muss also das reine Rechenergebnis A1-SA2 zugrunde gelegt werden. Andererseits erspare ich mir mit dem formulierten Inhalt von A3 eine zusätzlichen Schritt, um zu dem Text zu kommen, den ich im Textfeld sehen möchte.

An alle anderen: Ich werde mich in Ruhe an den angebotenen Lösungsvorschlägen versuchen.


Vorab aber schon einmal herzlichen Dank.


Hardbopper

[chris-ka]

Guten Morgen

welche Bedingung soll den zutreffen damit "Grün" erscheint?
soll der Wert größer als 100 sein?

ich mache das mal in der Demo...

Ohne bed. Formatierung da reicht auch 
[Farbe10][>100]"Ø ="#.##0 "kWh";"Ø ="#.##0 "kWh"

als "normale" Formatierung
und einem Eventmakro

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Range("A1:A2")
If Not Intersect(rng, Target) Is Nothing Then
    Shapes(1).TextFrame.Characters.Font.Color = Range("A3").DisplayFormat.Font.Color
End If
End Sub

  Übertragung eines Zellformats auf ein Textfeld.xlsm (Größe: 16,41 KB / Downloads: 3)

[Hardbopper]

Hallo Case, 

es funktioniert alles (auch in einer Tabelle mit mehreren Textfeldern) einwandfrei, danke !

Zu Klaus-Dieter: ein Textfeld kann selbstverständlich nicht bedingt formatiert werden, sondern diese Formatierung muss in der zugrunde liegenden Zelle (hier: A3) erfolgen.

Hardbopper

[Hardbopper]

Hallo Case,

ich muss doch noch einmal Deine Hilfe in Anspruch nehmen. Wie bereits berichtet, funktioniert Dein Lösungsvorschlag auch in einer Tabelle mit mehreren Textfeldern. Wenn ich aber versuche, das Ganze auf eine Tabelle zu übertragen, die Bestandteil einer Arbeitsmappe ist, scheitere ich.

Es geht um die Arbeitsmappe "Gasverbrauch" und dort um das Arbeitsblatt  "Regressionsmodell". Ich habe die bedingte Formatierung der Zelle Z15 absichtlich verändert, um kontrollieren zu können, ob das Makro funktioniert, die Farbe des maßgeblichen Textfeldes ist aber nach wie vor grün, obwohl sie sich zu violett verändern müsste. Auch ein Austausch der shape-Nummern hat kein Ergebnis gebracht.

Ich hoffe, Dich nicht über Gebühr in Anspruch zu nehmen.

Die Arbeitsmappe habe ich beigefügt.


  Gasverbrauch.xlsm (Größe: 369,96 KB / Downloads: 3)

Hardbopper

[Case]

Moin moin, :19:

du hast auf dem Tabellenblatt "Regressionsmodell" mehrere nicht genutzte Textfelder. In "N27" liegen zwei übereinander. :21:

   

Kannst du auch sehen, indem du auf...

"Start - Bearbeiten - Suchen und Auswählen - Gehe zu... - Inhalte... - Objekte - OK" gehst.

Oder du führst folgendes Makro aus: :21:

Code:

Option Explicit
Public Sub Shape_Info()
    Dim wksSheetNew As Worksheet
    Dim wksSheet As Worksheet
    Dim wksTMP As Worksheet
    Dim shpShape As Shape
    Dim lngRow As Long
    On Error GoTo Fin
    Application.ScreenUpdating = False
    For Each wksTMP In ThisWorkbook.Worksheets
        If wksTMP.Name = "Info_Shapes" Then
            Application.DisplayAlerts = False
            wksTMP.Delete
            Application.DisplayAlerts = True
        End If
    Next wksTMP
    Set wksSheet = Tabelle10
    If wksSheet.Shapes.Count < 1 Then
        MsgBox "No Shapes in the current worksheet!"
        Exit Sub
    End If
    Set wksSheetNew = Worksheets.Add(Before:=Worksheets(1))
    wksSheetNew.Name = "Info_Shapes"
    For Each shpShape In wksSheet.Shapes
        With wksSheetNew
            .Cells(lngRow + 1, 2) = shpShape.Name
            .Cells(lngRow + 1, 2).Font.Bold = True
            .Cells(lngRow + 1, 2).HorizontalAlignment = xlRight
            .Cells(lngRow + 1, 1) = "Name"
            .Cells(lngRow + 2, 2) = shpShape.Type
            .Cells(lngRow + 2, 1) = "Type"
            .Cells(lngRow + 3, 2) = shpShape.AutoShapeType
            .Cells(lngRow + 3, 1) = "AutoShapeType"
            .Cells(lngRow + 4, 2) = shpShape.Height
            .Cells(lngRow + 4, 1) = "Height"
            .Cells(lngRow + 5, 2) = shpShape.Width
            .Cells(lngRow + 5, 1) = "Width"
            .Cells(lngRow + 6, 2) = shpShape.Top
            .Cells(lngRow + 6, 1) = "Top"
            .Cells(lngRow + 7, 2) = shpShape.Left
            .Cells(lngRow + 7, 1) = "Left"
            .Cells(lngRow + 8, 2) = shpShape.TopLeftCell.Column
            .Cells(lngRow + 8, 1) = "TopLeftCell.Column"
            .Cells(lngRow + 9, 2) = shpShape.TopLeftCell.Row
            .Cells(lngRow + 9, 1) = "TopLeftCell.Row"
            .Cells(lngRow + 10, 2) = shpShape.TopLeftCell.Address(0, 0)
            .Cells(lngRow + 10, 1) = "TopLeftCell.Address"
            .Cells(lngRow + 10, 2).HorizontalAlignment = xlRight
            If shpShape.OnAction = "" Then
                .Cells(lngRow + 11, 2) = "No macro assigned!"
            Else
                .Cells(lngRow + 11, 2) = shpShape.OnAction
                .Cells(lngRow + 11, 2).Font.ColorIndex = 3
            End If
            .Cells(lngRow + 11, 1) = "OnAction"
            .Cells(lngRow + 11, 2).HorizontalAlignment = xlRight
            lngRow = lngRow + 12
        End With
    Next
    With wksSheetNew
        .Range(Cells(1, 1), _
            Cells(.Rows.Count, 1).End(xlUp)).Rows.Font.Bold = True
        .Columns("A:B").AutoFit
    End With
Fin:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set wksSheetNew = Nothing
    Set wksSheet = Nothing
End Sub

Du kannst das auch über den Namen des Shapes machen. Dieser Name wird automatisch beim Erstellen vergeben und du kannst ihn dir im Namensfeld (links oben, vor der Bearbeitungszeile) anzeigen und dort auch ändern (hierzu einfach das Shape selektieren und den angezeigten Namen überschreiben).

Mit Name: :21:

Code:

Tabelle10.Shapes("TextBox 8").TextFrame.Characters.Font.Color = Tabelle10.Range("Z15").DisplayFormat.Font.Color