FORMÜLLÜ HÜCREYİ KISMEN KOYU YAPMAK

[baydeniro]

Merhaba Arkadaşlar,
Kısmen metin kısmen formül ile birleştirilen veri elde edilen bir hücrede metin kısmının NORMAL, formül ile elde edilen kısmın KOYU olmasını sağlamak mümkün müdür ?
örneğin B1 hücresi
="UEFA sıralamasında Arnavutlukun yeri : "&KAÇINCI(A1;C1:C5;0)

 

[askm]

Formül ile yapılması mümkün değil ama dilerseniz örnek dosya eklerseniz makro ile yapılabilir.

 

[baydeniro]

teşekkür ederim askm üstadım. hemen ekliyorum dosyayı

 

[Ömer BARAN]

Merhaba.
Bence, belgede başka makro kullanılmıyorsa sadece bu işlem için makro oluşturmak yerine;
>> D1 hücresine, hücre hizalamasını SAĞa olarak ayarlayıp, =A1&" : UEFA sıralamasındaki yeri : " formülünü uygulamak,
>> E1 hücresinin yazıtipini KOYU olarak ayarlayıp, =KAÇINCI(A1;C1:C5;0) formülünü uygulamak,
>> Bu iki hücrenin arkaplan rengini aynı yapıp aralarına, hücre arkaplan rengiyle aynı renkte kenarlık uygulamak
en pratik çözüm olur.
.

 

[baydeniro]

askm üstadım dosyanın linki
http://s3.dosya.tc/server17/br76ji/KISMI_KOYULASTIRMA.xls.html

 

[baydeniro]

Ömer BARAN üstadım ilginize teşekkür ediyorum. 2. yol olarak tavsiyenizi de dikkate alacağım. sağlıcakla kalın.

 

[askm]

Sayfa kod bölümüne aşağıdaki kodları ekleyin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set Rng = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
say = Application.Match(Range("A1").Value, Rng, 0)
kelime1 = "UEFA sıralamasında " & Range("A1") & "yeri : "
Range("B1") = kelime1 & say
Range("B1").Characters(Len(kelime1), 2).Font.Bold = True
Application.ScreenUpdating = True
End Sub

 

[baydeniro]

askm üstadım çok çok teşekkür ediyorum. Formüllü kısmı koyulaştıran çok harika bir kod oldu. Müthiş bir şey bu.
Acaba bir de Formüllü kısmı aynen burakıp, Formüllü olmayan kısmı koyulaştırmak mümkün mü ?
Ben epeyce kurcaladım ama beceremedim

 

[askm]

Aşağıdaki şekilde değiştirin

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set Rng = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
say = Application.Match(Range("A1").Value, Rng, 0)
kelime1 = "UEFA sıralamasında " & Range("A1") & " yeri : "
Range("B1") = kelime1 & say
Range("B1").Characters(1, Len(kelime1)).Font.Bold = True
Application.ScreenUpdating = True
End Sub

 

[baydeniro]

askm üstadım çok çok teşekkür ederim. Mükemmel. Allah tuttuğunuz altın etsin.
Üstadım, bu kodu B sütununda 2.satırdan aşağıya doğru 750. satıra kadar her satırda çalışacak şekilde düzenlenmesi mümkün müdür ! yoksa sadece 1 hücrede mi çalışabilir !

 

[askm]

Belirttiğiniz şekilde örnek eklerseniz C deki veriler sabit mi kalacak. 3-5 satırlık bir örnek ekleyin kodda düzeltme yapayım.

 

[baydeniro]

teşekkürler üstad.
yeni örneği ekledim.
http://s7.dosya.tc/server9/islhop/KISMI_KOYULASTIRMA.xls.html

 

[askm]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:A65536")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Cells(Target.Row, 2).Font.Bold = False
Set Rng = Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row)
say = Application.Match(Target.Value, Rng, 0)
kelime1 = "UEFA sıralamasında " & Target.Value & " yeri : "
Cells(Target.Row, 2) = kelime1 & say
Cells(Target.Row, 2).Characters(1, Len(kelime1) - 1).Font.Bold = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[baydeniro]

üstad askm şahanesin vesselam. çok çok teşekkür ediyorum.