Zelle in Farbe bei Sicherung

Hallo !
Ich nehme dieses Makro um Daten die ich täglich einpflege zu sichern um in der Zukunft darauf zugreifen zu können. Da funktioniert bestens.
Nun wäre es hilfreich auch die Textfarbe beim sichern zu übernehmen, Gerade bei der Sicherung der Spalte C14. Diese ist manchmal in schwarzem Text und hin und wieder in rotem Text. Gibts dafür eine Möglichkeit das Makro dahingehend zu ändern um dies zu bewerkstelligen ?
Danke im voraus
chris58

Sub ProtokollSichern()
Dim i As Long
Const NewConstSheet As String = "Berechnung"
Dim bfound As Boolean
Dim sMerk As String
Dim sMaxZeile As Long
Dim TB As Worksheet

Application.ScreenUpdating = False

'Prüfen ob Tabelle NewConstSheet schon angelegt ist
For i = 1 To ActiveWorkbook.Sheets.Count
If ActiveWorkbook.Sheets(i).Name = NewConstSheet Then
bfound = True
Exit For
End If
Next i

'wenn nicht dann anlegen
If bfound = False Then
sMerk = ActiveWorkbook.ActiveSheet.Name
ActiveWorkbook.Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveWorkbook.ActiveSheet.Name = NewConstSheet
ActiveWorkbook.Sheets(sMerk).Activate
End If

Set TB = ActiveWorkbook.Sheets(NewConstSheet)

'nächste leere Zeile ermitteln
sMaxZeile = TB.Cells(TB.Rows.Count, 1).End(xlUp).Row + 1

'Daten in neue Tabelle übertragen
TB.Cells(sMaxZeile, 1) = ActiveWorkbook.ActiveSheet.Range("C7")
TB.Cells(sMaxZeile, 2) = ActiveWorkbook.ActiveSheet.Range("B7")
TB.Cells(sMaxZeile, 3) = ActiveWorkbook.ActiveSheet.Range("C6")
TB.Cells(sMaxZeile, 4) = ActiveWorkbook.ActiveSheet.Range("C11")
TB.Cells(sMaxZeile, 5) = ActiveWorkbook.ActiveSheet.Range("C12")
TB.Cells(sMaxZeile, 6) = ActiveWorkbook.ActiveSheet.Range("C13")
TB.Cells(sMaxZeile, 7) = ActiveWorkbook.ActiveSheet.Range("C14")
TB.Cells(sMaxZeile, 9) = ActiveWorkbook.ActiveSheet.Range("D7")

' Formel in Spalte H
TB.Cells(sMaxZeile, 8).FormulaR1C1 = "=(RC3-R[-1]C3)/(RC1-R[-1]C1)"

Application.ScreenUpdating = True
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub ProtokollSichern() Dim i As Long Dim Q Application.ScreenUpdating = False With Blatt_holen(ActiveWorkbook, "Berechnung") 'letzt befüllte Zeile ermitteln und auf die näcshte Daten übertragen With .Cells(TB.Rows.Count, 1).End(xlUp).Row For Each Q In Split("C7 B7 C6 C11 C12 C13 C14 D7") .Offset(1, i) = Range(Q) i = i + 1 Next .Offset(1, 8).FormulaR1C1 = "=(RC3-R[-1]C3)/(RC1-R[-1]C1)" With .Range("A1:H1") .Font.Color = -11489280 'Schriftfarbe grün Set Q = .FormatConditions.Add(Type:=xlExpression, Formula1:="=(A10)") 'wenn negativ Q.Font.Color = -16776961 'dann rot End With End With End With Application.ScreenUpdating = True End Sub Private Function Blatt_holen(wb As Workbook, Blattname As String) As Worksheet On Error Resume Next 'gibt nur von hier bis Ende dieses Sub/Function Set Blatt_holen = wb.Worksheets(Blattname) 'wenn es nicht existiert, verursacht es eine Fehler, die ignoriert wird If Blatt_holen Is Nothing Then Set ws = ws.Worksheets(wb.workshets.Count) 'wenn nichts gefunden, dann herstellen End Function

Hallo !
Da ich nicht weiterkomme und keine Lösung in VBA bisher gefunden habe und ich nicht versiert genug bin um dies selber zu lösen, habe ich eine Formel zusammengestickt die die Lösung wäre, wenn die Nachkomma nur auf 2 Stellen gerundet wären. Doch auch da stoße ich auf mein Wissen, das in diesr Hinsicht nicht vorhanden ist.
Entweder geht das mit diesem Makro, wo die Zahlen nicht in Rot oder Grün sind, sondern mit einem Minus und einem Plus vor der berechneten Zahl.

Sub Vergleich()
Dim Unterschied As Double
Unterschied = Cells(5, 3) - Cells(12, 3)
  Cells(14, 3) = Abs(Unterschied)
  Cells(14, 3).Font.Color = IIf(Unterschied  0, vbRed, vbGreen)
End Sub

oder, bei dieser zusammengeflickten Formel, wenn diese nur 2 Nachkomme hätte:
=WENN(C12-C5>0;"+";"-")&" "&C5-C12

Bevorzugen würde ich ja die Lösung mit dem Makro, aber ich würde auch mit der Formel zufrieden sein.
Wie ihr seht, ich bin kein Profi, weit dvon entfernt. Ich bemühe mich ja um eine Lösung, nur ................naja
Danke jednefalls fürs Lesen
chris

Sub Vergleich() With Range("C14") 'das ist die Zelle, worauf alles passieren soll (alles was bis zu End With mit einem Punkt anfängt bezieht sich auf diesem With) .Value = Range("C5").Value - Range("C12").Value 'die Differenz in C14 ablegen .Font.Color = IIf(.Value 0, vbRed, vbGreen) ' Farbe nach Vorzeichen setzen .Value = Abs(.Value) 'Vorzeichen vernichten End With End Sub

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread