Text kutusuna gelen değere tıklayıp resme gitmek

[orkuncan5]

Ekteki dosyada text kutusuna gelen değere tıklayarak ilgili resmin üzerindeki şekle gitmek istiyorum.Sorum daha ayrıntılı olarak ektedir.

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz.

Private Sub TextBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
    Dim shp As Shape, deg1 As String, deg2 As String
 
    Application.ScreenUpdating = False
 
    On Error Resume Next
    Sheets("" & TextBox2.Text & "").Select
 
    deg1 = UCase(Replace(Replace(TextBox3.Text, "ı", "I"), "i", "İ"))
 
    For Each shp In ActiveSheet.Shapes
        If shp.FormControlType = xlTextBox Then
            shp.Select
            deg2 = UCase(Replace(Replace(Selection.Characters.Text, _
                    "ı", "I"), "i", "İ"))
            If deg2 = deg1 Then
                Selection.Characters.Font.ColorIndex = 3
            Else
                Selection.Characters.Font.ColorIndex = 6
            End If
        End If
    Next shp
 
    Range("A1").Select
    Application.ScreenUpdating = True
 
End Sub

.

 

[orkuncan5]

Ömer Bey tam istediğim gibi olmuş.Teşekkür ederim.

 

[halit3]

Ekteki dosyada text kutusuna gelen değere tıklayarak ilgili resmin üzerindeki şekle gitmek istiyorum.Sorum daha ayrıntılı olarak ektedir.

Kod boşuna gitmesin Alternatif olarak

otomatik şekillerin içine ilçe isimlerini yazarsanız kod çlışıyor örnek olarak bolu sayfasında yapılmıştır.

Private Sub TextBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Set S1 = Sheets(TextBox2.Text)
Dim Picture As Object
For Each Picture In S1.Shapes
If TypeName(S1.Shapes(Picture.Name).OLEFormat.Object) = "Rectangle" Then
On Error Resume Next
If LCase(Trim(S1.Shapes(Picture.Name).OLEFormat.Object.Characters.Text)) = LCase(Trim(TextBox3.Text)) Then
S1.Select
S1.Shapes(Picture.Name).OLEFormat.Object.Select
S1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor = 10
Else
S1.Shapes(Picture.Name).OLEFormat.Object.ShapeRange.Fill.ForeColor.SchemeColor = 13
End If
End If
Next Picture
End Sub

 

[orkuncan5]

Halit Bey teşekkür ederim.Örneğiniz güzel olmuş.

 

[halit3]

Halit Bey teşekkür ederim.Örneğiniz güzel olmuş.

İyi çalışmalar

 

[orkuncan5]

Hayırlı akşamlar.Ömer Beyin verdiği koda göre textboxa tıkladığımızda textboxdaki yazının aynısı ilgili sayfasında renk değiştiriyor.Bu koda ilaveten sadece tıkladığımız textboxun çevresinde renkli halka oluşturabilirmiyiz.Yani ilçe textboxunda Düzce adına tıkladığımızda ,ilgili sayfadaki düzce adı hem renk değiştirecek hemde çevresinde renkli halka olacak.Yardımcı olursanız sevinirim.

 

[halit3]

Hayırlı akşamlar.Ömer Beyin verdiği koda göre textboxa tıkladığımızda textboxdaki yazının aynısı ilgili sayfasında renk değiştiriyor.Bu koda ilaveten sadece tıkladığımız textboxun çevresinde renkli halka oluşturabilirmiyiz.Yani ilçe textboxunda Düzce adına tıkladığımızda ,ilgili sayfadaki düzce adı hem renk değiştirecek hemde çevresinde renkli halka olacak.Yardımcı olursanız sevinirim.

Ömer Beyin Koduna ilaveler yaptım.

Ancak text nesneleri hücrelere ait sol dan ve üsteki klavuz cizgileri ile aynı olacak yoksa halka aşağı yukarı veya sağ,sola kaymayı önlüyemeyiz.

Örnek olarak bolu sayfası düzce yazan nesne nin sol üst keşesi B5 hücresine ait klavuz çizgisinin üst ve sol kısmının kesiştiği yer aynı hizada olacak.

Private Sub TextBox3_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim shp As Shape, deg1 As String, deg2 As String
Application.ScreenUpdating = False
On Error Resume Next
Sheets("" & TextBox2.Text & "").Select
Dim Picture As Object
Set S1 = Sheets(TextBox2.Text)
For Each Picture In ActiveSheet.Shapes
If TypeName(S1.Shapes(Picture.Name).OLEFormat.Object) = "Rectangle" Then
Picture.Delete
End If
Next Picture
deg1 = UCase(Replace(Replace(TextBox3.Text, "ı", "I"), "i", "İ"))
For Each shp In ActiveSheet.Shapes
If shp.FormControlType = xlTextBox Then
shp.Select
deg2 = UCase(Replace(Replace(Selection.Characters.Text, "ı", "I"), "i", "İ"))
If deg2 = deg1 Then
Selection.Characters.Font.ColorIndex = 3
Cells(Val(shp.BottomRightCell.Row), Val(shp.BottomRightCell.Column)).Select
orta = ActiveWindow.Selection.Top - 10
sol = ActiveWindow.Selection.Left - 50
ActiveSheet.Shapes.AddShape(msoShapeDonut, sol, orta, 65#, 65).Select
Selection.ShapeRange.Adjustments.Item(1) = 0.0682
Selection.ShapeRange.IncrementLeft -6#
Selection.ShapeRange.IncrementTop -13.5
[COLOR=red]Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10[/COLOR]
Else
Selection.Characters.Font.ColorIndex = 6
End If
End If
Next shp
Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[orkuncan5]

Teşekkür ederim Halit Bey.Sizi çok uğraştırmış olmalıyım.Hakkınızı helal edin.

 

[orkuncan5]

Halit Bey ilçe isimlerinin üzerine gelen halkanın rengini nasıl kırmızı yaparız ,uğraştım ama beceremedim.

 

[halit3]

Halit Bey ilçe isimlerinin üzerine gelen halkanın rengini nasıl kırmızı yaparız ,uğraştım ama beceremedim.

8 nolu mesaja kırmızı renkli bölümü ekledim.

 

[orkuncan5]

Ellerinize sağlık.