Inhalte Farbig markieren

Question

Hallo zusammen,

in einer Spalte habe ich Zellen mit genauen Maßangaben (L X B X H). Nun möchte ich, dass wenn die B(reite) größer als 3,01 Meter ist, die Zelle farbig markiert wird.

Habe es mit rechts und links versucht, sobald aber in einer Zelle mehrere Zeilen mit Maßangaben gibt, hätte meine Formel schon verloren.

Die Zellen in Excel 2007 sehen beispielsweise so aus:

in Zelle J2

3,00 x 2,20 x 2,85

in Zelle J3 - Zelle sollte markiert werden

2,20 x 0,80 x 1,25
3,50 x 1,60 x 2,20
4,50 x 3,10 x 2,20

in Zelle J4 - Zelle sollte markiert werden

4,50 x 3,25 x 4,00

Es ist leider momentan noch nicht möglich, die Maße auf 3 Spalten aufzuteilen.

Kann mir hier jemand bei helfen.

Vielen Dank schon mal im Voraus

Gruß
Florian

Answer 1

Hallo Florian,

ich habe inzwischen auch noch etwas gebastelt :-).

Das folgende Makro markiert alle Zeilen in Spalte J, bei denen die Breite größer als 3,01 ist. Das klappt auch mit den Zellen, die mehrere Zeilen enthalten. Das Makro muss in ein Standard-Modul kopiert werden. Probiere es aber erst einmal in einer Testtabelle aus:

Sub ueberbreite()

Dim anfang, ende, zeichen, zeile As Long

For zeile = 2 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For zeichen = 1 To Len(Cells(zeile, 10).Value)
If Mid(Cells(zeile, 10).Value, zeichen, 1) = "x" And anfang = 0 Then anfang = zeichen + 1
If Mid(Cells(zeile, 10).Value, zeichen, 1) = "x" And anfang > 0 Then ende = zeichen - 1

If Mid(Cells(zeile, 10).Value, zeichen, 1) = Chr(10) Or zeichen = Len(Cells(zeile, 10).Value) Then
If CDbl(Trim(Mid(Cells(zeile, 10).Value, anfang, ende - anfang))) > 3.01 Then
Cells(zeile, 10).Interior.ColorIndex = 3
Exit For
End If
anfang = 0
End If

Next zeichen
anfang = 0

Next zeile

End Sub

Gruß

M.O.

Answer 2

Hallo M.O.

vielen Dank für´s basteln. Ich find es immer wieder spektakulär, was du aus Excel alles raus holst.

Nur bricht es bei meinem Sheet in der Zeile:

If CDbl(Trim(Mid(Cells(zeile, 10).Value, anfang, ende - anfang))) > 3.01 Then

ab.

Ich habe gerade gesehen, dass nicht alle Zeilen in J beschrieben sind und noch schlimmer, bei manchen sogar nur Länge x Breite OHNE Höhe steht. So wie ich dein Makro lese, dürfte das den Fehler auslösen.

Kannst du dort ein ODER einbauen, sprich L x B x H oder, wenn die Höhe fehlt, dann nur L x B.

Gruß
Florian


Ach ja, bevor ich es vergesse: Happy Eastern ;-)

Answer 3

Hallo zusammen,

Habe das Makro von @M.O. auch getestet und es funktioniert , wenn in den Zellen L x B x H angegeben sind, sollte nur L x B enthalten sein, gibt es auch bei mir die gleiche Fehlermeldung im Makro.
Es geht aber auch nicht, wenn z.B. die Zelle J3 mit Zeilenumbruch formatiert ist und mehr als ein Maß eingetragen ist.

Die Zellen in Spalte J werden jedoch über UserForm befüllt, in dem Fall muß vielleicht die Zelle J3 gar nicht mit Zeilenumbruch formatiert sein.

Da es hier bereits um VBA geht, kann ich mangels ausreichender Kenntnisse ohnehin nicht mitreden, aber es wäre interessant wie die Zelle J3 in Deiner Tabelle formatiert ist.

Mit bedingter Formatierung würde es so aussehen:

Formel ist:
=UND(TEIL(J2;8;4)>"3,01")

Es werden sowohl die Zellen in Spalte J (L x B x H) als auch (L x B) farblich markiert, auch wenn die Zellen mit Zeilenumbruch formatiert sind, sollte aber in einer Zelle mehr als ein Maß untereinander stehen, ist der Ofen aus.

Sollte nur als Info dienen.


weiterhin frohe Ostern
mit Gruß

Paul1

Excel 2003

Answer 4

Hallo Florian,

probier mal ob das überarbeitete Makro so funktioniert, wie du es willst:

Sub ueberbreite_neu()

Dim anfang, ende, zeichen, zeile As Long

For zeile = 2 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

If Len(Cells(zeile, 10).Value) > 0 Then

For zeichen = 1 To Len(Cells(zeile, 10).Value)

If Mid(Cells(zeile, 10).Value, zeichen, 1) = "x" Then
If anfang > 0 Then ende = zeichen - 1
If anfang = 0 Then anfang = zeichen + 1
End If

If Mid(Cells(zeile, 10).Value, zeichen, 1) = Chr(10) Or zeichen = Len(Cells(zeile, 10).Value) Then

If ende = 0 Then ende = Len(Cells(zeile, 10).Value)


If CDbl(Trim(Mid(Cells(zeile, 10).Value, anfang, ende - anfang))) > 3.01 Then
Cells(zeile, 10).Interior.ColorIndex = 3
Exit For
End If
anfang = 0
ende = 0
End If

Next zeichen
anfang = 0
ende = 0

End If

Next zeile

End Sub

Gruß

M.O.

Answer 5

Hallo zusammen,

@ M.O. vielen Dank für dein neues Makro. Hab es gerade getestet. Hier heißt es allerdings "Laufzeitfehler '13': Typen unverträglich."

Hab ich da was falsch gemacht, oder was könnte das bedeuten?

@ Paul1 - ebenfalls vielen Dank. Ich fürchte, du hast mit deiner Aussage recht. Aber vielleicht hat M.O. doch noch eine Lösung gefunden. Wäre super.

Jedenfalls allen schon mal ein guter Start in die neue Woche (mit Zeitumstellung - man kot... mich das an...)

Gruß
Florian

Answer 6

Hallo Florian,

in meiner (von mir erstellten) Testtabelle funktioniert das Makro ohne Fehler. Steht in der Spalte J vielleicht noch etwas anderes als deine Angaben zur Länge, Breite und Höhe.
Ggf. kannst du ja mal eine Beispieldatei hochladen (siehe meine Antwort 10) und den Link dann hier posten.

Ansonsten hier ein Makro mit Fehlerbehandlung :-).

Sub ueberbreite_Fehler()

Dim anfang, ende, zeichen, zeile As Long

For zeile = 2 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

If Len(Cells(zeile, 10).Value) > 0 Then

For zeichen = 1 To Len(Cells(zeile, 10).Value)

If Mid(Cells(zeile, 10).Value, zeichen, 1) = "x" Then
If anfang > 0 Then ende = zeichen - 1
If anfang = 0 Then anfang = zeichen + 1
End If

If Mid(Cells(zeile, 10).Value, zeichen, 1) = Chr(10) Or zeichen = Len(Cells(zeile, 10).Value) Then

If ende = 0 Then ende = Len(Cells(zeile, 10).Value)

On Error GoTo Fehler:

If CDbl(Trim(Mid(Cells(zeile, 10).Value, anfang, ende - anfang))) > 3.01 Then
Cells(zeile, 10).Interior.ColorIndex = 3
Exit For
End If
anfang = 0
ende = 0
End If

Next zeichen
anfang = 0
ende = 0

End If

Next zeile

Exit Sub

Fehler:

MsgBox "Fehler in Zeile " & zeile, 16, "Fehler"
Cells(zeile, 10).Select

End Sub

Und nicht aufregen! Heute ist doch schon Dienstag :-).

Gruß

M.O.

Answer 7

Hallo M.O.

der Wochentag wäre es ja gar nicht, aber die Zeitumstellung ist jedes mal ein Krampf. Braucht doch kein Mensch, oder?

Ich hab jetzt mal die Tabelle gekürzt und ich hoffe, du kannst damit was anfangen.


PR-GESAMT-TESTOBJEKT.xlsm]PR GESAMT TESTOBJEKT

Danke für eure Hilfe.

Gruß
Florian

Answer 8

Hallo Florian,

in der Tabelle sind auch Daten nur mit Höhe und Breite mit Zeilenumbruch, daher die Fehlermeldung.
Ich schaue mir das mal an.

Gruß

M.O.

Answer 9

Hallo M.O.,

das stimmt leider - siehe Antwort 12:

Ich habe gerade gesehen, dass nicht alle Zeilen in J beschrieben sind und noch schlimmer, bei manchen sogar nur Länge x Breite OHNE Höhe steht. So wie ich dein Makro lese, dürfte das den Fehler auslösen.

Kannst du dort ein ODER einbauen, sprich L x B x H oder, wenn die Höhe fehlt, dann nur L x B.

Gruß
Florian

Answer 10

Hallo Florian,

deine Antwort 12 habe ich gelesen, aber nicht daran gedacht, dass auch mehrere Daten untereinander stehen können :-(.

Ich habe das Makro angepasst und es sollte jetzt funktionieren (außer in Zeile 510, da diese nicht der Norm der anderen Zeilen entspricht; es bricht jedoch nicht ab):

Sub ueberbreite()

Dim anfang, ende, zeichen, zeile As Long

For zeile = 2 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

If Len(Cells(zeile, 10).Value) > 1 And Cells(zeile, 10).NumberFormat <> "0.00%" Then

For zeichen = 1 To Len(Cells(zeile, 10).Value)

If Mid(Cells(zeile, 10).Value, zeichen, 1) = "x" Then
If anfang > 0 Then ende = zeichen - 1
If anfang = 0 Then anfang = zeichen + 1
End If

If Mid(Cells(zeile, 10).Value, zeichen, 1) = Chr(13) Or zeichen = Len(Cells(zeile, 10).Value) Then

If ende = 0 Then ende = zeichen - 1

On Error Resume Next

If CDbl(Trim(Mid(Cells(zeile, 10).Value, anfang, ende - anfang))) > 3.01 Then
Cells(zeile, 10).Interior.ColorIndex = 3
Exit For
End If
anfang = 0
ende = 0
End If

Next zeichen
anfang = 0
ende = 0

End If

Next zeile

Exit Sub

End Sub

Füge den Code bitte in ein allgemeines Modul ein, nicht in das Projekt des Arbeitsblattes.

Mir ist aufgefallen, dass die Daten falsch in bzw. aus der Userform1 (Kisten) übertragen werden. Das liegt daran, dass die Textboxen für die Höhe noch hinzugefügt wurden.
Ich habe mal ein bisschen rumgebastelt und die Prüfung für die Überbreite gleich mit in die Userform eingebaut :-):
Testdatei bearbeitet
Das geänderte Makro ist natürlich auch schon in der bearbeiteten Datei enthalten.

Gruß

M.O.