Kleur cel overnemen uit ander tabbald op basis van achtergrondkleur bij waarde

[maartennijboer]

Ik ben bezig met een magazijn indeling.

Elke stelling in dit magazijn heeft een achtergrondkleur gekregen op basis van makkelijke bereikbaarheid, tabblad 1.
In tabblad 2 staan de artikelen en de locatie daarachter, de stellingen hebben ook planken vandaar de langere locatie naam.
Voor de werkelijke locatie heb ik de verkorte locatie naam gezet middels de formule LINKS(A1;4).

De bedoeling is dat wanneer ik de achtergrondkleur in het eerste tabblad verander dat dan de achtergrondkleur van de locatie in tabblad 2 automatisch ook zich aanpast.

Middels voorwaardelijke opmaak is dit niet mogelijk omdat deze anders ook steeds moet veranderen.

In de bijlage staat een voorbeeld bestand, dit voorbeeld is een klein magazijn maar in werkelijkheid is deze vele malen groter.
Maar heeft het nog steeds maar vijf verschillende kleuren.

Kunnen jullie mij helpen hiermee?

Alvast bedankt.

 

[edmoor]

Wijzig de kleur d.m.v. een dubbelklik op zo'n cel in het blad Magazijn:
Bekijk bijlage Kopie van Voorbeeld 1.xlsm

 

[SjonR]

deze achter het tabblad magazijn?

Private Sub Worksheet_Activate()
For Each cl In Range("B2:B33,F2:F33,J2:J37")
    cl.Offset(, -1).Resize(, 3).Interior.Color = Sheets("Magazijn").Range("B2:E10").Find(cl).Interior.Color
Next
End Sub

 

[maartennijboer]

@ SjonR

Wat jij als voorbeeld hebt gemaakt dat ziet er goed uit.
Ik krijg het alleen niet voor elkaar.

Zou u het werkend willen maken in de volgende bijlage?

 

[emields]

Als je het werkende wil krijgen zal je eerst nog wat werk hebben om uw locatie-magazijn met het magazijn in overeenstemming te brengen. Hoe kan een mens weten dat ab.11 overeenstemt met 103049?

 

[maartennijboer]

@emields

Bij de locaties die niet een op de sheet magazijn staan is het ook niet nodig om ze te kleuren.

Er zijn genoeg artikelen zonder locatie of met ????, en nummer of --- als locatie, deze zijn niet van belang.

 

[emields]

geef eens een schriftelijk voorbeeld van een locatie op het blad magazijn die ook op het blad locatie staat. Anders moetje maar eens kijken op het bestand dat je geplaatst hebt

 

[maartennijboer]

Als je kijkt op blad magazijn T6, daar zie je staan CA1.08 en je kijkt op blad locatie cellen D27121 t/m D27135 daar zie je ook CA1.08 staan.

Voorbeeld 2

Als je kijkt op blad magazijn V13, daar zie je staan CA2.01 en als je kijkt op blad locatie cellen D27136 t/m D2738 zie je ook staan CA2.01, dit is een deel (eerste 6 tekens van de werkelijke locatie)

De bedoeling is dat CA2.01 in blad locatie de kleur overneemt uit blad magazijn, en dat wanneer ik in blad magazijn deze verander dat in blad locatie deze mee veranderd.

 

[SjonR]

even geduld bij het uitvoeren, maar doet volgens mij wat je wilt:

Sub SjonR() 
Application.ScreenUpdating = False
For i = 2 To Range("D" & Rows.Count).End(xlUp).Row
    If Cells(i, 4).Value <> "" Then
        Set C = Sheets("Magazijn").Range("B3:DK44").Find(Cells(i, 4).Value)
        If Not C Is Nothing Then Cells(i, 3).Interior.Color = C.Interior.Color
    End If
Next
Application.ScreenUpdating = True
End Sub

 

[maartennijboer]

@ SjonR

Heel erg bedankt, dit lijkt inderdaad te werken.
Ik zal er even mee aan de slag verder en mocht het werkend blijven sluit ik het topic.

 

[VenA]

Bij veel data kan je beter array's gebruiken. Onderstaande is ruim 4 x sneller

Sub VenA()
  Application.ScreenUpdating = False
  With Sheets("Magazijn").UsedRange
    ar = .Value
    ReDim ar1(.SpecialCells(2).Count, 1)
    For j = 1 To UBound(ar)
      For jj = 1 To UBound(ar, 2)
        If ar(j, jj) <> "" Then
          ar1(t, 0) = ar(j, jj)
          ar1(t, 1) = .Cells(j, jj).Interior.Color
          t = t + 1
        End If
      Next jj
    Next j
  End With
    
  With Sheets("Locaties")
    ar = .Cells(1).CurrentRegion
    For j = 1 To UBound(ar)
      If Not IsError(ar(j, 4)) Then
        For jj = 0 To UBound(ar1)
          If Trim(ar(j, 4)) = Trim(ar1(jj, 0)) Then
            .Cells(j, 3).Interior.Color = ar1(jj, 1)
            Exit For
          End If
        Next jj
      End If
    Next j
  End With
End Sub

 

[maartennijboer]

Nog niet perfect. @SjonR kan je me helpen

SjonR,

Ik was erg tevreden met de oplossing die jij mij geboden hebt echter nu ik een vernieuwde lijst er in zet kleurt hij maar een gedeelte van de cellen in kolom D en niet heel de kolom D.
Zelf weet ik niet waarom, de lijst met artikelen is misschien iets langer geworden maar dat moet volgens mij niet uitmaken.

Zou jij weten wat de oorzaak zou kunnen zijn?

Het nieuwe bestand uploaden lukt niet, deze is nu rond de 3 MB en de maximale grote voor uploaden mag 2 MB zijn, zelfs na het zippen is het bestand groter als 2MB.

Alvast bedankt.

 

[VenA]

Als alleen SjonR je verder mag helpen dan hoop ik voor jou dat hij/zij daar zin in heeft.

 

[maartennijboer]

Nee hoor, ook jij mag me helpen.
Maar ik was met zijn script verder gegaan vandaar.

Jij had het over dat ik beter array's kon gebruiken omdat dit sneller zou zijn.
Ik heb de code die jij geschreven hebt er in geplakt en dan kleurt hij op dit moment een hoop meer cellen, perfect.
Maar ook een aantal nog niet, is het hoofdletter gevoelig, of zou dat niet uit moeten maken?

Alvast bedankt.

 

[VenA]

Nee hoor, ook jij mag me helpen.

Bijzonder. Er zijn hier veel meer helpers die meer weten dan SjonR en ik bij elkaar. Deze worden dus blijkbaar uitgesloten?

In VBA is bijna alles case sensitive. Alles is te ondervangen maar hoe beter het voorbeeldbestand hoe beter de suggesties zullen zijn. Je kan ook even zoeken op Option Compare of Lcase