Harita renklendirme

[cuneytturkoglu]

Merhabalar ,
harita üzerinde illeri alttaki bölgelere göre ilgili renklere boyamak istiyorum ama beceremedim

 

[Ömer BARAN]

Merhaba bu konuda forumda örnekler olması lazım.

Sayfaya bir adet şekil/düğme/metin kutusu ekleyin ve bu nesne ile aşağıdaki kod'u bağlayın,
bu nesneye tıkladığınızda istediğiniz işlem gerçekleşir.

NOT: İSTANBUL ilinin bölgesini AVRUPA veya ANADOLU yazmayı unutmayın.
.

Sub BOLGELER()
adet = ActiveSheet.Shapes.Count
Application.ScreenUpdating = False
For sekil = 1 To adet
    isim = ActiveSheet.Shapes(sekil).Name
    If Mid(isim, 1, 9) = "Freeform " Then
    Set r = [A29:A109].Find(Replace(isim, "Freeform ", ""), , , xlWhole)
    If Not r Is Nothing Then
        renk = Cells(WorksheetFunction.Match(Cells(r.Row, 4), [J29:J36], 0) + 28, "I").Interior.Color
        R1 = renk Mod 256
        G1 = (renk \ 256) Mod 256
        B1 = (renk \ 256 \ 256) Mod 256
        ActiveSheet.Shapes(sekil).Select
            With Selection.ShapeRange.Fill
                .Visible = msoTrue: .ForeColor.RGB = RGB(R1, G1, B1)
            End With
    End If
    End If
Next
[A1].Activate
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation, "..:: Ömer BARAN ::.."
End Sub

 

[ÖmerBey]

Merhaba,
Alternatif olsun... Ekteki dosyayı inceleyiniz.

Düzeltme: Ekteki dosyayı il ismine göre yapmıştım, Freeform no sütununu yeni farkettim. Freeform numarasına göre şu kodlarla doğrudan renklendirme yapılabilir. (Ekteki dosyadaki kodlar birazcık farklı)

Sub Renklendir()
Dim hcr As Range, bolge As Range
Application.ScreenUpdating = False
For Each hcr In Range(Cells(29, "A"), Cells(Rows.Count, "A").End(3))
    Set bolge = Range("J29:J36").Find(hcr.Offset(0, 3).Value)
    ActiveSheet.Shapes("Freeform " & hcr.Value).Select
    If Not bolge Is Nothing Then
        Selection.Interior.Color = bolge.Offset(0, -1).Interior.Color
    Else
        Selection.Interior.ColorIndex = 0
    End If
Next
Application.ScreenUpdating = True
Range("A1").Select
MsgBox "İşlem tamam."
End Sub