Harita il ilçe renklendrime

[berkmaz]

Merhaba,
ekteki tabloda TR haritası olduğu gibi ilçe haritasınından kriterlere gore 81 ili ilçe detayından renklendirilmesini yapmak istiyorum
örnek olarak Adana ilçe haritasını ekledim her ilçeye ID numarısı verdim
sizlerin yardımları sonrası ben tüm 81 il ilçe detayında ayrı ayrı sayfalarda aynı formulü kullanarak tablomu oluşturmak istiyorum
konu hakkında yardımlarınızı rica ederim

 

[Ergün GÖKER]

ilçeleri yapamazsınız, çünkü llçeleri çizen olmadı daha. il sınırları çizilmiş bir sürü harita bulabilirsiniz ama ilçeleri maalesef bulamazsınız.

 

[Baggwell]

Takipteyim

 

[berkmaz]

Adana ilini çizdim yaklaşık 15 dakikamı aldı, zaman buldukça diğer illeri çizmeye çalışacam

 

[Baggwell]

Değerlere göre şehirleri renklendirmek mümkün mü ?

 

[berkmaz]

Harita il ilçe renklendirme

Merhaba,
daha once eklediğim tabloyu sıkıştırmadığımdan makrosunun silindiğini fark ettim
tekrardan ekliyorum amacım iller haritasında olduğu gibi ilçelerinde renklendirilmesini istiyorum örnek olarak 1 (Adana) 2 (Adıyaman) ilçe haritasını ekledim sonrasında 81 il ilçe detayında haritaları çizerek kapsamlı bir harita oluşturacam.
şimdiden yardımlarınız için teşekkür ederim
iyi çalışmalar

 

[berkmaz]

Harita il ilçe renklendirme

Merhaba,
biraz kurcaladım olur gibi oldu ama nerede yanlış yapıyorum bilmiyorum
ilçe sayfasında bulunan ilçe ıd'lerine rakam yazıyorum sonrasında 1 veya 2 sayfasına gittiğimde hata uyarısı veriyor end tuşuna basınca bir kaç tane ilçenin renkleri değişiyor ama ne hikmetse hepsi değişmiyor
birde ilçe kriterinde kriter rakamlarını değiştirdiğimde illaki içine girip çift tıklamam gerekiyor bunun için ne yapmam lazım?
bu arada kafayı yemek üzereyim
iyi çalışmalar.

 

[halit3]

Ekli dosyada renklendirme ile ilgili farklı bir yaklaşım bulunmakta.

Deneme sayfası örnek olarak yapılmıştır.
Açıklama :
1-nesnelerin hepsini çözün.
2-isimleri sıralandır düğmesine tıklayın.
3-isimleri bul düğmesine tıklayın.
4-Mevcut isimler R ve W sütununda sıralanmış olacaktır. Drawing nesneleri için T sütunu text nesneleri için Y sütununa isim yazıp isimleri değiştir düğmesine tıklayın.
5-Mevcut renklendirme sayıları U ve Z sütununda sıralanmış olacaktır. Drawing nesneleri için V sütunu text nesneleri için A sütununa renk sayısı yazıp renklendir düğmesine tıklayın.

 

[halit3]

Dosyayı yeniden güncelledim.

 

[berkmaz]

Ekli dosyada renklendirme ile ilgili farklı bir yaklaşım bulunmakta.

Deneme sayfası örnek olarak yapılmıştır.
Açıklama :
1-nesnelerin hepsini çözün.
2-isimleri sıralandır düğmesine tıklayın.
3-isimleri bul düğmesine tıklayın.
4-Mevcut isimler R ve W sütununda sıralanmış olacaktır. Drawing nesneleri için T sütunu text nesneleri için Y sütununa isim yazıp isimleri değiştir düğmesine tıklayın.
5-Mevcut renklendirme sayıları U ve Z sütununda sıralanmış olacaktır. Drawing nesneleri için V sütunu text nesneleri için A sütununa renk sayısı yazıp renklendir düğmesine tıklayın.

halit bey,
öncelikle çok teşekkür ederim eğer mümkünse renklendir düğmesine basınca tek tek onay vermek yerine bir seferde işlem yapması mümkün mü?
iyi çalışmalar

 

[halit3]

halil bey,
öncelikle çok teşekkür ederim eğer mümkünse renklendir düğmesine basınca tek tek onay vermek yerine bir seferde işlem yapması mümkün mü?
iyi çalışmalar

Ne dediğinizi tam olarak anlamadım 8 nolu mesajdaki dosyayı değiştirmiştim. renklendir düğmesine tıklayınca V sütununa yazdığınız değerlere göre renklendirme yapıyor.

 

[halit3]

Dosyayı yeniden derledim.
Açıklama

1-İsimleri sıralandır düğmesine tıkla
2-T ve Z sütunlarına değişecek isimleri yaz ve isimleri değiştir düğmesine tıkla
3-U sütununa renk kodunu yaz ve renklendir düğmesini tıkla

kısaca yeşil ve sarı renkli bölümlere değiştireceğiniz değeri yazın.

 

[berkmaz]

Dosyayı yeniden derledim.
Açıklama

1-İsimleri sıralandır düğmesine tıkla
2-T ve Z sütunlarına değişecek isimleri yaz ve isimleri değiştir düğmesine tıkla
3-U sütununa renk kodunu yaz ve renklendir düğmesini tıkla

kısaca yeşil ve sarı renkli bölümlere değiştireceğiniz değeri yazın.

halit bey,
isimleri değiştir düğmesine basınca hata veriyor
selamlar

 

[halit3]

halit bey,
isimleri değiştir düğmesine basınca hata veriyor
selamlar

Görsel videoyu yükledim irdeleyiniz.

görsel video

 

[berkmaz]

Görsel videoyu yükledim irdeleyiniz.

görsel video

Halit Bey,
son yaptığınız tabloyu eklemniz mümkün mü
selamlar

 

[halit3]

kodlar:

Sub Auto_Open()
MenuSil
menü1
End Sub
Sub Auto_Close()
Application.CommandBars("Cell").Reset
MenuSil
End Sub

Sub isimlerisirala()

Range("R2:S100").ClearContents
Range("X2:Y100").ClearContents
Range("v2:v100").ClearContents

'On Error Resume Next
Dim Picture As Object

On Error Resume Next

For Each Picture In ActiveSheet.Shapes
nesne = TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object)
If nesne = "GroupObject" Then
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Ungroup
End If

Next Picture


sat1 = 2
sat2 = 2
For Each Picture In ActiveSheet.Shapes
nesne = TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object)

If nesne = "Drawing" Then
i = i + 1
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name = "Drawing" & i

Cells(sat1, "r") = "Drawing" & i
Cells(sat1, "s") = nesne
sat1 = sat1 + 1

End If

If nesne = "TextBox" Then
i = i + 1
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name = "TextBox" & i
Cells(sat2, "X") = "TextBox" & i
Cells(sat2, "Y") = nesne
sat2 = sat2 + 1
End If
If nesne = "GroupObject" Then
i = i + 1
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name = "GroupObject" & i
End If

Next Picture

MsgBox "işlem tamam"
End Sub
Sub isimlenidegistir()

j = 2
i = 2

'On Error Resume Next
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes


If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Drawing" Then

say = say + 1
If Cells(i, "t") <> "" Then
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name = "A " & Cells(i, "t")
'ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = Cells(i, "t") 'ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name
Cells(i, "R") = "A " & Cells(i, "t")
i = i + 1
End If

End If


If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "TextBox" Then

say = say + 1
If Cells(j, "Z") <> "" Then
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name = "B " & Cells(j, "Z")
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Characters.Text = Cells(j, "Z") 'ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name
Cells(j, "X") = "B " & Cells(j, "Z")
j = j + 1
End If
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Font.Size = 10
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.HorizontalAlignment = xlCenter
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.VerticalAlignment = xlCenter
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ReadingOrder = xlContext
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Orientation = xlHorizontal
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.AutoSize = False
End If

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "GroupObject" Then
say = say + 1
End If

Next Picture

MsgBox "işlem tamam"
End Sub
Sub renklendir()
j = 2
i = 2
On Error Resume Next
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Drawing" Then

'Cells(i, "r").Value = ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name
Cells(i, "V").Value = ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.Visible = msoTrue
ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor = Cells(i, "U").Value
i = i + 1
End If

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "TextBox" Then
j = j + 1
'Cells(j, "x").Value = ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.Name
'Cells(J, "z").Value = ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor
'ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor = Cells(J, "aa").Value
'ActiveSheet.Shapes(Picture.Name).ShapeRange.Fill.ForeColor.SchemeColor = 25
'ActiveSheet.Shapes(Picture.Name).ShapeRange.Fill.Visible = msoTrue
'ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.Visible = msoFalse
'ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor = 2
End If

Next Picture
MsgBox " Düzenleme Tamanlanmıştır..."
End Sub





Sub MenuSil()

Application.CommandBars("Worksheet Menu Bar").Reset
'Application.CommandBars("Cell").Reset
Dim cmdBar As CommandBar
For Each cmdBar In Application.CommandBars
If cmdBar.Name <> "Standard" Then
If cmdBar.Name <> "Formatting" Then
'On Error Resume Next
'cmdBar.Reset
End If
End If
Next
End Sub

Sub menü1()
Dim AnaMenu As CommandBarControl

Set AnaMenu = Application.CommandBars(1).Controls.Add(msoControlPopup, , , , True)
With AnaMenu
.Caption = "Makrolar"
.BeginGroup = False
'.OnAction = "Yatay"
End With
With AnaMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "İsimleri sıralandır"
.OnAction = "isimlerisirala"
.FaceId = 251
End With
With AnaMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "isimleri değiştir"
.OnAction = "isimlenidegistir"
.FaceId = 189
End With
With AnaMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "renklendir"
.OnAction = "renklendir"
.FaceId = 298
End With


End Sub

 

[berkmaz]

Halit Bey,
isimleri değiştir makrosunu çalıştırdığımda aşağıdaki şekilde hata veriyor

ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ReadingOrder = xlContext
makro'lardan bu değeri sildiğimde sorunsuz çalışıyor
ellerinize sağlık
iyi çalışmalar

 

[halit3]

Halit Bey,
isimleri değiştir makrosunu çalıştırdığımda aşağıdaki şekilde hata veriyor

ActiveSheet.Shapes(Picture.Name).OLEFormat.Object.ReadingOrder = xlContext
makro'lardan bu değeri sildiğimde sorunsuz çalışıyor
ellerinize sağlık
iyi çalışmalar

Teşekkürler iyi çalışmalar.
Yapmış olduğunuz ilçelere ait düzenlemeleri buraya ekleyin takip edelim

 

[tamer42]

Merhaba,
Bu haritada İstanbul ilçelerinin çizilmiş halini bulmamız mümkün müdür?

teşekkürler, iyi çalışmalar.