Excel Macro kleuren + opmaak

[Verwijderd]

Zou iemand de code kunnen maken/verbeteren voor de kleurenvlakken van de postcodes + een opmaak voor b.v. boven die 10 leveringen dan een rood vlak.

Link bestand: http://www.mediafire.com/...20per%20postcode%20V3.xls

[breew]

Welkom.
Wat heb je zelf al geprobeerd, wat werkte wel/niet/gedeeltelijk? Dit voorkomt dubbele antwoorden.

Verder: Ik download liever geen excel-bestanden uit onbekende bron; al helemaal niet als deze voorzien zijn van macro's.
Er lopen meer hier mensen rond met deze mening, dus als je je kans op een antwoord wilt vergroten:
Leg je huidige werkboek, je probleem en de gewenste uitkomst helder uit, liefst voorzien van screenshots. Macro-code die je wilt laten zien liefst tussen code-tags

[code=vb] plak hier je code [/code]

.

Dan mbt je vraag:
Is een macro persé nodig denk je? Vaak kun je met de juiste voorwaardelijke opmaak al snel een heel eind komen.

[ Voor 14% gewijzigd door breew op 22-02-2018 09:59 ]

[Verwijderd]

Ik heb niet genoeg karma om een foto toe te voegen van het bestand.
Zoals het bestand nu is werkt het. Ik wil toevoegen dat er b.v. bij meer dan 10 leveringen het vlak van de postcode rood wordt. Met alleen voorwaardelijke opmaak gaat het niet werken.

Het is nu zo dat een kaart van Nederland in verdeeld in 4 kleuren.
Per team een andere kleur b.v. team
Noord = Groen
Zuid = Blauw

Met de macro knop voor kleur map of ontkleur map waarmee je dus de kleur van het team kan wijzigen en dan de map opnieuw kunt inkleuren. Ik wil er graag aan toevoegen dat als er b.v. meer dan 10 leveringen zijn per postcode dat het vlak rood wordt.

Code in Module 1

Visual Basic:

 Option Explicit

Sub ColorMap()
Dim c As Range
Dim myStr As String
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
Dim i As Integer, str As String
Dim arr
ActiveSheet.Range("U:U").ClearContents
For i = 1 To ActiveSheet.Shapes.Count
        
        With ActiveSheet.Shapes(i)
        'str = ActiveSheet.Shapes(i).Name
        If .Type = msoGroup Then
        
          .Ungroup
          End If
          End With
          Next
For i = 1 To ActiveSheet.Shapes.Count
With ActiveSheet.Shapes(i)
If Left(.Name, 8) = "Freeform" Then
str = str & "/" & .Name
End If
End With
Next
str = Mid(str, 2)
arr = Split(str, "/")
ActiveSheet.Range("U3").Resize(UBound(arr) + 1) = Application.Transpose(arr)
For Each c In [U3:U127]
On Error Resume Next
    myStr = Right("000000" & Hex(c.Offset(0, 1).Interior.Color), 6)
    lRed = Application.Evaluate("=Hex2dec(""" & Right(myStr, 2) & """)")
    lGreen = Application.Evaluate("=Hex2dec(""" & Mid(myStr, 3, 2) & """)")
    lBlue = Application.Evaluate("=Hex2dec(""" & Left(myStr, 2) & """)")
    ActiveSheet.Shapes(c).Fill.ForeColor.RGB = RGB(lRed, lGreen, lBlue)

Next

End Sub
 

Code in sheet 1

Visual Basic:

 Option Explicit

Private Sub CommandButton1_Click()
Dim c As Range
Dim myStr As String
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
Dim i As Integer, str As String
Dim arr
Range("V3:V1000").ClearContents
For i = 1 To Shapes.Count
        
        With Shapes(i)
        
        If .Type = msoGroup Then
        
          .Ungroup
          End If
          End With
          Next
For i = 1 To Shapes.Count
With Shapes(i)
If Left(.Name, 8) = "Freeform" Then
str = str & "/" & .Name
End If
End With
Next
str = Mid(str, 2)
arr = Split(str, "/")
Range("V3").Resize(UBound(arr) + 1) = Application.Transpose(arr)
For Each c In [U3:U127]
On Error Resume Next
    myStr = Right("000000" & Hex(c.Offset(0, -1).Interior.Color), 6)
    lRed = Application.Evaluate("=Hex2dec(""" & Right(myStr, 2) & """)")
    lGreen = Application.Evaluate("=Hex2dec(""" & Mid(myStr, 3, 2) & """)")
    lBlue = Application.Evaluate("=Hex2dec(""" & Left(myStr, 2) & """)")
    Shapes(c).Fill.ForeColor.RGB = RGB(lRed, lGreen, lBlue)
   
 
Next

End Sub

Private Sub CommandButton2_Click()
Dim c As Range
Dim myStr As String
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long




For Each c In [U3:U127]
On Error Resume Next
   
    
    Shapes(c).Fill.ForeColor.RGB = RGB(255, 255, 255)
 
Next
Range("V3:V1000").ClearContents
End Sub
 

[breew]

Een code met functionele opmerkingen erbij is wat makkelijker leesbaar ;-)

Waar/hoe bepaal je het aantal leveringen?

Algemeen: probeer termen als ActiveSheet en ActiveWorkbook zoveel mogelijk te vervangen door 'harde' verwijzingen naar werkbladen en -boeken (tenzij het niet anders kan). Dat voorkomt vaak een hoop onbedoelde effecten...

ietwat offtopic: Laat je ook even weten wat de antwoorden zijn van het HelpMij forum en eventuele andere kanalen waar je in gecrosspost hebt?

[ Voor 27% gewijzigd door breew op 22-02-2018 13:01 ]

[rense]

Je zou de regel (function Commandbutton1_Click)

VBScript:

    myStr = Right("000000" & Hex(c.Offset(0, 1).Interior.Color), 6)

kunnen vervangen door

VBScript:

        If c.Offset(0, 4) > 10 Then
            myStr = "0000FF"
        Else
            myStr = Right("000000" & Hex(c.Offset(0, -1).Interior.Color), 6)
        End If

Wat de oorspronkelijk code doet is de postcodegebieden met de naam in kolom U de kleur van kolom T geven. De nieuwe code kijkt naar kolom Y (Totaal) of deze een waarde hoger dan 10 heeft. Zo ja, neem kleur rood, zo nee, neem de kleur uit kolom T.

[Verwijderd]

Ik had het als eerst op het HelpMij forum gepost, maar ik kwam die niet verder. Daarna dus hier gepost.

[Verwijderd]

Rense bedankt!
Dat is precies wat ik zocht.