Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
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

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: farbliche Nummern suchen und markieren
10.12.2009 20:00:24
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

Anzeige
AW: farbliche Nummern suchen und markieren
10.12.2009 20:08:10
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
10.12.2009 20:22:37
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

Anzeige
@Sepp : Mein "akademisches Viertelstündchen" ;-)
10.12.2009 20:23:41
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?
10.12.2009 20:27:04
Josef
Hi NoNet,
hast du dir ein paar Formelnudeln mit VBA-Sauce zubereitet;-))
Siehst du, an .ReplaceFormat hab ich gar nicht gedacht.
Gruß Sepp

Anzeige
Na also wenn Du so konkret fragst ;-)
10.12.2009 20:38:40
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
10.12.2009 20:16:05
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
Anzeige

313 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige