Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen

farbliche Nummern suchen und markieren | Herbers Excel-Forum


Betrifft: farbliche Nummern suchen und markieren von: Bernie
Geschrieben am: 10.12.2009 19:35:16

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

  

Betrifft: AW: farbliche Nummern suchen und markieren von: Josef Ehrensberger
Geschrieben am: 10.12.2009 20:00:24

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



  

Betrifft: AW: farbliche Nummern suchen und markieren von: Bernie
Geschrieben am: 10.12.2009 20:08:10

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


  

Betrifft: Kleine Korrektur von: Josef Ehrensberger
Geschrieben am: 10.12.2009 20:22:37

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



  

Betrifft: @Sepp : Mein "akademisches Viertelstündchen" ;-) von: NoNet
Geschrieben am: 10.12.2009 20:23:41

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


  

Betrifft: @ NoNet, was gab's den gutes? von: Josef Ehrensberger
Geschrieben am: 10.12.2009 20:27:04

Hi NoNet,

hast du dir ein paar Formelnudeln mit VBA-Sauce zubereitet;-))

Siehst du, an .ReplaceFormat hab ich gar nicht gedacht.

Gruß Sepp



  

Betrifft: Na also wenn Du so konkret fragst ;-) von: NoNet
Geschrieben am: 10.12.2009 20:38:40

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 ;-) :



MAAAHLZEIT !!!!

Gruß, NoNet


  

Betrifft: Zellfarben gemäß Legende formatieren von: NoNet
Geschrieben am: 10.12.2009 20:16:05

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


Beiträge aus den Excel-Beispielen zum Thema "farbliche Nummern suchen und markieren"