HERBERS Excel-Forum - das Archiv
Bewerten Sie hier bitte das Excel-Portal
farbliche Nummern suchen und markieren
Bernie

Hallo Spezialisten,
Aus einem Programm bekomme ich eine Excel-Tabelle aufbereitet, in welcher 2 Spalten mit Material-Nummern vorhanden sind.
Jetzt möchte ich gerne die Spalten so farblich markieren, daß dort Nummern, welche ich zuvor als Legende gekennzeichnet und farblich markiert habe, in den Spalten der Material-Nummern gesucht und so farblich markiert werden, wie die Legenden-Nummer. Bisher habe ich das immer manuell mit der bedingten Formatierung gemacht, was aber ziemlich zeitaufwendig ist (Beispiel)
https://www.herber.de/bbs/user/66496.xls
Gibt es die Möglichkeit diese Markierung über ein VBA-Makro durchführen zu lassen?
Diese müsste in der Legendenspalte die erste Zahl mit den beiden Tabellen vergleichen und im Trefferfall die Nummer mit gleicher Farbe markieren. Dann nächste Zahl suchen, einfärben usw.
Vielleicht hat jemand eine Idee wie ich das hin bekommen könnte.
Bernie

AW: farbliche Nummern suchen und markieren
Josef

Hallo Bernie,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub markieren()
  Dim rngIndex As Range, rngList As Range, rng As Range
  Dim varResult As Variant
  
  On Error Resume Next
  
  Set rngIndex = Application.InputBox("Bitte den Legendenbereich auswählen" & vbLf & _
    "Der Bereich darf nur eine Spalte umfassen!", "Legende", Selection.Address, Type:=8)
  
  If Not rngIndex Is Nothing Then
    If rngIndex.Columns.Count > 1 Then rngIndex = rngIndex.Columns(1)
    Set rngList = Application.InputBox("Bitte den Listenbereich auswählen" & vbLf & _
      "Der Listenbereich darf auch mehrspaltig sein!", "Liste", _
      Range("A1").CurrentRegion.Address, Type:=8)
    
    If Not rngList Is Nothing Then
      rngList.Interior.ColorIndex = xlNone
      For Each rng In rngList
        varResult = Application.Match(rng, rngIndex, 0)
        If IsNumeric(varResult) Then
          rng.Interior.Color = rngIndex(varResult, 1).Interior.Color
        End If
      Next
    End If
  End If
  
  Set rng = Nothing
  Set rngIndex = Nothing
  Set rngList = Nothing
End Sub

Gruß Sepp

AW: farbliche Nummern suchen und markieren
Bernie

Hallo Sepp,
der absolute Wahnsinn - das klappt super.
Ich muss mir das Ganze intensiv unter die Lupe nehmen, damit ich den Code verstehe.
Nochmals vielen Dank für die super schnelle Hilfe.
Bernie
Kleine Korrektur
Josef

Hallo nochmal,
eine kleine Korrektur um einen Fehler bei mehrspaltiger Legendenauswahl zu vermeiden.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub markieren()
  Dim rngIndex As Range, rngList As Range, rng As Range
  Dim varResult As Variant
  
  On Error Resume Next
  
  Set rngIndex = Application.InputBox("Bitte den Legendenbereich auswählen" & vbLf & _
    "Der Bereich darf nur eine Spalte umfassen!", "Legende", Selection.Address, Type:=8)
  
  If Not rngIndex Is Nothing Then
    If rngIndex.Columns.Count > 1 Then Set rngIndex = rngIndex.Resize(, 1)
    Set rngList = Application.InputBox("Bitte den Listenbereich auswählen" & vbLf & _
      "Der Listenbereich darf auch mehrspaltig sein!", "Liste", _
      Range("A1").CurrentRegion.Address, Type:=8)
    
    If Not rngList Is Nothing Then
      rngList.Interior.ColorIndex = xlNone
      For Each rng In rngList
        varResult = Application.Match(rng, rngIndex, 0)
        If IsNumeric(varResult) Then
          rng.Interior.Color = rngIndex(varResult, 1).Interior.Color
        End If
      Next
    End If
  End If
  
  Set rng = Nothing
  Set rngIndex = Nothing
  Set rngList = Nothing
End Sub

Gruß Sepp

@Sepp : Mein "akademisches Viertelstündchen" ;-)
NoNet

Hey Sepp,
da warst Du doch über 15 Min. schneller als ich - das hat man nun davon, wenn man während der Erarbeitung einer Lösung sein Abendessen zubereitet ...
Bin gespannt, welche Version Bernie letztendlich verwenden wird.
Mir ist da im Code ein kleiner Fauxpas passiert : Da ich auf diesem Notebook kein "Option Explicit" aktiviert habe, habe ich doch glatt Dim rngZelle as Range vergessen ;-)
Schönen Abend, Gruß NoNet
@ NoNet, was gab's den gutes?
Josef

Hi NoNet,
hast du dir ein paar Formelnudeln mit VBA-Sauce zubereitet;-))
Siehst du, an .ReplaceFormat hab ich gar nicht gedacht.
Gruß Sepp

Na also wenn Du so konkret fragst ;-)
NoNet

Hey Sepp,
Formelnudeln und VBA-Sauce gibt es bei mir so oft, da habe ich mir heute Abend mal etwas anderes im Ofen gemacht - hier ein Originalfoto (PS : Im Original ist das alles zum Glück etwas grösser ;-) :
Userbild
MAAAHLZEIT !!!!
Gruß, NoNet
Zellfarben gemäß Legende formatieren
NoNet

Hey Berni,
markiere Deinen Bereich B41:B53 und benenne ihn mit "Legende" (im Namensfeld oberhalb Zelle A1 !).
Kopiere dann dieses Makro in ein allgemeines Modul (z.B. "Modul1") im VBA-Editor :
Sub FarbenGemaessLegende()
Application.ReplaceFormat.Clear
For Each rngzelle In Range("Legende")
Application.ReplaceFormat.Interior.ColorIndex = rngzelle.Interior.ColorIndex
Intersect(Range("B:C"), Range("B2").CurrentRegion).Replace What:=rngzelle.Value, _
Replacement:=rngzelle.Value, LookAt:=xlWhole, SearchFormat:=False, _
ReplaceFormat:=True
Next
End Sub
Wenn Du dann noch die "Bedingte Formatierung" des Legendenbereiches löschst, erhältst Du das gewünschte Ergebnis !
Gruß, NoNet