rote Zahlen automatisch unterstreichen.

[WillWissen]

Hi,

das ist der Mist mit den verbundenen Zellen (http://www.clever-excel-forum.de/Thread-...oder-Segen)

Du solltest versuchen, diese aufzulösen; dann dürfte auch Andrés Vorschlag funktionieren.

[eao44]

vielleicht ein anderer ansatz:

die roten Messwerte sind ja ebensfalls unterstrichen... gibt es die möglichkeit die zellen wie gewünscht zusammen zufügen, jedoch sollen die bereits unterstrichenen zahlen übernommen werden.
damit ich dann eben auf mein gewünschtes Ergebnis komme.

[Rabe]

Hi,

die roten Messwerte sind ja ebensfalls unterstrichen... gibt es die möglichkeit die zellen wie gewünscht zusammen zufügen, jedoch sollen die bereits unterstrichenen zahlen übernommen werden.
damit ich dann eben auf mein gewünschtes Ergebnis komme.

Und wie atilla gestern schon schrieb:

...dann möchtest Du einen Teil des Formelergebnisses unterstreichen, das ist nicht möglich in Formeln!

Vielleicht will jemand ein Makro schreiben, das die drei Zellen anschaut, zusammenfügt und sucht, ob ein Messwert in den Ursprungszellen unterstrichen ist und dann diesen Part auch unterstreicht. Ich kann das nicht.

[RPP63]

Hi!
Ihr kennt mich ja als durchaus hilfsbereit, aber ehrlich gesagt habe ich keine Lust, so etwas in meinen Augen höchst kontraproduktives zu erledigen.
@eao44: Dies ist nicht gegen Dich gerichtet!
Nur manchmal sollte man seinem Kunden freundlich durch die Blume mitteilen, dass sein Wunsch nicht sinnvoll ist.

... beim nächsten Problem helfe ich dann wieder gerne ...

Gruß Ralf

[atilla]

Hallo,

ich habe da mal etwas zusammengebastelt.
Das einfügen in eine andere Mappe habe ich weggelassen. Das kannst Du manuell auch schnell rüber kopieren.

Da ich davon ausgehe, dass nicht nur die Spalte E sonder auch die folgenden Spalten G, I usw. auch noch berücksichtigt werden sollen, habe ich sie mit reingenommen.

Füge in Deiner Datei mit den Messungen eine weitere Tabelle ein. Benenne diese "Zusammenfassung", dann lass den unten stehen Code laufen.

Code:

Option Explicit

Sub zuzammenfassen()
Dim lngZ As Long, i As Long, j As Long, k As Long
Dim wert1 As Long, wert2 As Long, wert3 As Long
Dim arrTab As Variant
Dim arrIn()
Dim arrStatus()
arrTab = Array("Schuss 1", "Schuss 2", "Schuss 3")

With Sheets(arrTab(0))
   lngZ = .Cells(.Rows.Count, 5).End(xlUp).Row
End With

ReDim arrIn(0, (lngZ - 21) * 8)
ReDim arrStatus(0, (lngZ - 21) * 8)
For j = 5 To 19 Step 2
   For i = 0 To lngZ - 22
       arrIn(0, k) = Sheets(arrTab(0)).Cells(i + 22, j).Text & "/" & Sheets(arrTab(1)).Cells(i + 22, j).Text & "/" & Sheets(arrTab(2)).Cells(i + 22, j).Text
       If Sheets(arrTab(0)).Cells(i + 22, j) > Sheets(arrTab(0)).Cells(i + 22, 2) + Sheets(arrTab(0)).Cells(i + 22, 3) Or Sheets(arrTab(0)).Cells(i + 22, j) < Sheets(arrTab(0)).Cells(i + 22, 2) + Sheets(arrTab(0)).Cells(i + 22, 4) Then
           wert1 = 1
       Else
           wert1 = 0
       End If
       If Sheets(arrTab(1)).Cells(i + 22, j) > Sheets(arrTab(1)).Cells(i + 22, 2) + Sheets(arrTab(1)).Cells(i + 22, 3) Or Sheets(arrTab(1)).Cells(i + 22, j) < Sheets(arrTab(1)).Cells(i + 22, 2) + Sheets(arrTab(1)).Cells(i + 22, 4) Then
           wert2 = 1
       Else
           wert2 = 0
       End If
       If Sheets(arrTab(2)).Cells(i + 22, j) > Sheets(arrTab(2)).Cells(i + 22, 2) + Sheets(arrTab(2)).Cells(i + 22, 3) Or Sheets(arrTab(2)).Cells(i + 22, j) < Sheets(arrTab(2)).Cells(i + 22, 2) + Sheets(arrTab(2)).Cells(i + 22, 4) Then
           wert3 = 1
       Else
           wert3 = 0
       End If
       arrStatus(0, k) = wert1 & "/" & wert2 & "/" & wert3
       k = k + 1
   Next i
Next j

With Sheets("Zusammenfassung")
   .Columns("A").Clear
   .Range("A1").Resize(k) = Application.Transpose(arrIn)

   For i = 0 To ((lngZ - 21) * 8) - 1
       If Split(arrStatus(0, i), "/")(0) = 1 Then
           With .Cells(i + 1, 1).Characters(Start:=1, Length:=Len(Split(arrIn(0, i), "/")(0))).Font
               .Underline = xlUnderlineStyleSingle
               .Color = -16776961
           End With
       End If
       If Split(arrStatus(0, i), "/")(1) = 1 Then
           With .Cells(i + 1, 1).Characters(Start:=Len(Split(arrIn(0, i), "/")(0)) + 2, Length:=Len(Split(arrIn(0, i), "/")(1))).Font
               .Underline = xlUnderlineStyleSingle
               .Color = -16776961
           End With
       End If
       If Split(arrStatus(0, i), "/")(2) = 1 Then
           With .Cells(i + 1, 1).Characters(Start:=Len(Split(arrIn(0, i), "/")(0)) + Len(Split(arrIn(0, i), "/")(1)) + 3, Length:=Len(Split(arrIn(0, i), "/")(2))).Font
               .Underline = xlUnderlineStyleSingle
               .Color = -16776961
           End With
       End If
   Next i
   .Columns("A").HorizontalAlignment = xlCenter
End With
End Sub

Die Daten werden in der Tabelle "Zusammenfassung" in die Spalte A geschrieben. Von dort kannst Du sie dann in die andere Datei kopieren.
Es kann aber nicht in verbundene Zellen kopiert werden!!!!

Ralfs (RPP63) Meinung zu der Problemstellung, teile ich aber auch.

[eao44]

Hallo Zusammen,
ich habe nun einen Code zusammen gestellt, jedoch funktioniert sie nicht ... kann mir jemand sagen wo mein fehler ist"?

Sub zusammenkopieren()
Dim i As Long
Dim quelldatei As String
Dim quelltabelle1 As String
Dim quelltabelle2 As String
Dim quelltabelle3 As String
Dim zieldatei As String
Dim zieltabelle As String
quelldatei = "Messung.xls"
quelltabelle1 = "Schuss1"
quelltabelle2 = "Schuss2"
quelltabelle3 = "Schuss3"
zieldatei = ActiveWorkbook.Name
zieltabelle = ActiveSheet.Name
For i = 22 To Workbooks(quelldatei).Sheets(quelltabelle1).Cells(Rows.Count, 1).End(xlUp).Row
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 8).Value = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value & "/" & Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value
pos = 1
Workbooks(zieldatei).Sheets(zieltabelle1).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Font.Underline
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Value) + 1
Workbooks(zieldatei).Sheets(zieltabelle1).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle1).Cells(i, 5).Font.Underline
pos = pos + Len(Workbooks(quelldatei).Sheets(quelltabelle2).Cells(i, 5).Value) + 1
Workbooks(zieldatei).Sheets(zieltabelle).Cells(i, 4).Characters(Start:=pos, Length:=Len(Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Value)).Font.Underline = Workbooks(quelldatei).Sheets(quelltabelle3).Cells(i, 5).Font.Underline
Next i
End Sub

[atilla]

Hallo,


weil die Unterstreichung per Bedingter Formatierung erfolgt und die kann nicht so einfach ausgelesen werden.
Du musst die Bedingungen der Bedingten Formatierung in VBA einearbeiten.

Meinen Code möchtest Du nicht testen?!

[eao44]

Die Daten werden in der Tabelle "Zusammenfassung" in die Spalte A geschrieben. Von dort kannst Du sie dann in die andere Datei kopieren.
Es kann aber nicht in verbundene Zellen kopiert werden!!!!

Ralfs (RPP63) Meinung zu der Problemstellung, teile ich aber auch.

Wow vielen Dank!

[eao44]

Hallo,


weil die Unterstreichung per Bedingter Formatierung erfolgt und die kann nicht so einfach ausgelesen werden.
Du musst die Bedingungen der Bedingten Formatierung in VBA einearbeiten.

Meinen Code möchtest Du nicht testen?!

doch sorry ich hab das noch nicht gelesen gehabt

[schauan]

Hallöchen,

ich vermute, dass der Kunde alles in einer Zelle hat und den Inhalt über mehreren Zellen zentriert dargestellt hat. Die Werte sind ja auch nicht unterschiedlich gefärbt, und unterstrichen ist auch alles.

Und jetzt will er es also nicht mehr so?