Hallo,
Ik heb een stukje code gepakt van een zeer verouderde topic. Ik wil er mee aan het werk gaan maar ik kom er niet uit.
Code Sheet1
Code Module 1
Bekijk bijlage postcode bestand orgineel.xls
-------
Ik wil graag toevoegen dat als het aantal b.v. boven 10 komt de postcode een rode opmaak krijgt, hoe doe ik dat?
Ik heb een stukje code gepakt van een zeer verouderde topic. Ik wil er mee aan het werk gaan maar ik kom er niet uit.
Code Sheet1
Code:
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:U92]
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:U92]
On Error Resume Next
Shapes(c).Fill.ForeColor.RGB = RGB(255, 255, 255)
Next
Range("V3:V1000").ClearContents
End Sub
Code Module 1
Code:
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:U92]
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
-------
Ik wil graag toevoegen dat als het aantal b.v. boven 10 komt de postcode een rode opmaak krijgt, hoe doe ik dat?
Laatst bewerkt: