Makroda düzenleme

[abbasonline]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set s1 = Sheets("iller")
Set S2 = Sheets(ActiveSheet.Name)
İL = Cells(Target.Row, 2).Value
Set renk = [M:M].Find(Target.Value, lookat:=xlWhole)
If Not renk Is Nothing Then
rnk = Cells(renk.Row, "m").Interior.ColorIndex
Target.Interior.ColorIndex = rnk
Cells(Target.Row, 2).Interior.ColorIndex = rnk
End If
Set hcr = ActiveCell
Sheets("Harita").Select
ActiveSheet.Shapes(İL).Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = rnk + 7
Selection.ShapeRange.Fill.OneColorGradient msoGradientFromCenter, 1, 0.1
S2.Select
hcr.Select
Application.ScreenUpdating = True
End Sub



makrosu İller sayfasında (İller sayfasında her hangi bir hücreye tıkladığımda çalışıyor, ancak bunu nasıl yapıp da aynı özellik Harita sayfasında olabilir.)

 

[security]

Set s1 = Sheets("Harita")

seklinde uygulayın.. kırmızı yazılı kısmı değişin...

 

[abbasonline]

değiştirdim ama yine eski İller sayfasına tıklandığında çalışıyor Harita sayfasına tıkladığımda herhangi bir şey olmuyor.

 

[efeksk]

Harita sayfanızda süzdüğünüz verilerin aşağıda kırmızı ile işaretlenen SÜTUN isimlerini değiştirin

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [[COLOR="Red"]C:C[/COLOR]]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set s1 = Sheets("[COLOR="red"]Harita[/COLOR]")
Set S2 = Sheets(ActiveSheet.Name)
İL = Cells(Target.Row, 2).Value
Set renk = [M:M].Find(Target.Value, lookat:=xlWhole)
If Not renk Is Nothing Then
rnk = Cells(renk.Row, "m").Interior.ColorIndex
Target.Interior.ColorIndex = rnk
Cells(Target.Row, 2).Interior.ColorIndex = rnk
End If
Set hcr = ActiveCell
Sheets("Harita").Select
ActiveSheet.Shapes(İL).Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = rnk + 7
Selection.ShapeRange.Fill.OneColorGradient msoGradientFromCenter, 1, 0.1
S2.Select
hcr.Select
Application.ScreenUpdating = True
End Sub

 

[efeksk]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set s1 = Sheets("iller")
Set S2 = Sheets(ActiveSheet.Name)
İL = Cells(Target.Row, 2).Value
Set renk = [M:M].Find(Target.Value, lookat:=xlWhole)
If Not renk Is Nothing Then
rnk = Cells(renk.Row, "m").Interior.ColorIndex
Target.Interior.ColorIndex = rnk
Cells(Target.Row, 2).Interior.ColorIndex = rnk
End If
Set hcr = ActiveCell
Sheets("Harita").Select
ActiveSheet.Shapes(İL).Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = rnk + 7
Selection.ShapeRange.Fill.OneColorGradient msoGradientFromCenter, 1, 0.1
S2.Select
hcr.Select
Application.ScreenUpdating = True
End Sub



makrosu İller sayfasında (İller sayfasında her hangi bir hücreye tıkladığımda çalışıyor, ancak bunu nasıl yapıp da aynı özellik Harita sayfasında olabilir.)

dosyayı eklermisiniz

 

[efeksk]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C:C]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set s1 = Sheets("iller")
Set S2 = Sheets(ActiveSheet.Name)
İL = Cells(Target.Row, 2).Value
Set renk = [M:M].Find(Target.Value, lookat:=xlWhole)
If Not renk Is Nothing Then
rnk = Cells(renk.Row, "m").Interior.ColorIndex
Target.Interior.ColorIndex = rnk
Cells(Target.Row, 2).Interior.ColorIndex = rnk
End If
Set hcr = ActiveCell
Sheets("Harita").Select
ActiveSheet.Shapes(İL).Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = rnk + 7
Selection.ShapeRange.Fill.OneColorGradient msoGradientFromCenter, 1, 0.1
S2.Select
hcr.Select
Application.ScreenUpdating = True
End Sub



makrosu İller sayfasında (İller sayfasında her hangi bir hücreye tıkladığımda çalışıyor, ancak bunu nasıl yapıp da aynı özellik Harita sayfasında olabilir.)

Yukarıda belirtmiş olduğunuz sorun ile ilgili aşağıdaki yolu izleyiniz...

1- Yukarıda belirttiğiniz kodu Harita Sayfasına Kopyalayın. ve iller yazısını harita olarak değiştirin.
2- Excel üzerindeki butona sağ tıklayarak Makro düzenleme kutusunda herhangi bir dosya yolu belirtilmediğinden emin olun.