Buton İle Hücre İçerisindeki İstenilen Yeri Kalın Punto Yapmak

[ormann]

İyi günler;
ekli örnek dosyadaki D16 ve D17 hücre içerisindeki verilerin içerisinde bulunan ORMAN SAYILMAYAN YERLERDEN ve ORMAN SAYILAN YERLERDEN yazılı kelimeleri buton ile makro kullanarak kalın punto yapabilir miyiz ?.Yardımcı olur musunuz ?

http://dosya.co/oy9q3652q7rd/örnek.xls.html

 

[Ziynettin]

Mehaba,

Sub bicim()
Dim Krt_1 As String, Krt_2 As String
Dim Alan As Range, n1 As Integer, n2 As Integer
Krt_1 = "ORMAN SAYILMAYAN YERLERDEN"
Krt_2 = "ORMAN SAYILAN YERLERDEN"
    For Each Alan In [D16:D17]
        If Alan <> "" Then
            n1 = 1
            n2 = 1
            Do While n1 > 0 Or n2 > 0
                n1 = InStr(n1, UCase(Alan), UCase(Krt_1))
                n2 = InStr(n2, UCase(Alan), UCase(Krt_2))
                If n1 > 0 Or n2 > 0 Then
                    Alan.Characters(n1, Len(Krt_1)).font.Bold = 1
                    n1 = n1 + Len(Krt_1)
                    Alan.Characters(n2, Len(Krt_2)).font.Bold = 1
                    n2 = n2 + Len(Krt_2)
                End If
            Loop
        End If
    Next Alan
MsgBox "İşlem bitti.", vbInformation
End Sub

Bu şekilde deneyiniz.

 

[ormann]

Çok Teşekkür Ederim. Yalnız küçük harf ile yaptığım zaman olmuyor.Küçük harfe de duyarlı olabilir mi?

 

[Ziynettin]

Buyrun...

Sub bicim()
Dim Krt_1 As String, Krt_2 As String
Dim Alan As Range, n1 As Integer, n2 As Integer
Krt_1 = "ORMAN SAYILMAYAN YERLERDEN"
Krt_2 = "ORMAN SAYILAN YERLERDEN"
    For Each Alan In [D16:D17]
        If Alan <> "" Then
            n1 = 1
            n2 = 1
            Do While n1 > 0 Or n2 > 0
                veri = UCase(Replace(Replace(Alan, "ı", "I"), "i", "İ"))
                n1 = InStr(n1, veri, UCase(Krt_1))
                n2 = InStr(n2, veri, UCase(Krt_2))
                If n1 > 0 Or n2 > 0 Then
                    Alan.Characters(n1, Len(Krt_1)).Font.Bold = 1
                    n1 = n1 + Len(Krt_1)
                    Alan.Characters(n2, Len(Krt_2)).Font.Bold = 1
                    n2 = n2 + Len(Krt_2)
                End If
            Loop
        End If
    Next Alan
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[ormann]

Sayın Ziynettin ekli dosyada kırmızı ile belirttiğim alanları da kalın punt yapıyor
http://dosya.co/ifdkiieydcxi/örnek.xls.html

 

[Ziynettin]

Sub bicim()
Dim Krt_1 As String, Krt_2 As String
Dim Alan As Range, n1 As Integer, n2 As Integer
Krt_1 = "ORMAN SAYILMAYAN YERLERDEN"
Krt_2 = "ORMAN SAYILAN YERLERDEN"
    For Each Alan In [D16:D17]
        Alan.Font.Bold = 0
        If Alan <> "" Then
            n1 = 1
            n2 = 1
            veri = UCase(Replace(Replace(Alan, "ı", "I"), "i", "İ"))
            Do While n1 > 0
                n1 = InStr(n1, veri, UCase(Krt_1))
                If n1 > 0 Then
                    Alan.Characters(n1, Len(Krt_1)).Font.Bold = 1
                    n1 = n1 + Len(Krt_1)
                End If
            Loop
            Do While n2 > 0
                n2 = InStr(n2, veri, UCase(Krt_2))
                If n2 > 0 Then
                    Alan.Characters(n2, Len(Krt_2)).Font.Bold = 1
                    n2 = n2 + Len(Krt_2)
                End If
            Loop
        End If
    Next Alan
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[ormann]

Çok teşekkür ederim.Ellerinize sağlık.