Makro İle Hücredeki İstenilen Veriyi Kalın Punto Yapmak

[ormann]

İyi günler;ekli dosyada TextBox1 'e girilen veri ,rapor sayfasında D16 ve D17 hücresinde var ise butona bastığımızda D16 ve D17 hücresinde bulunan veri kalın punto olacak.Örneğin:TextBox1 'e 16-17-18 yazdığımda d16 ve d17 hücresinde 17 varsa tüm 17 ler kalın olacak.YYardımıcı olur musunuz ?

https://dosya.co/x1rou68r9jge/örnek.xls.html

 

[PLİNT]

Merhaba
"Texbox" da seçilmesi istenen veriler birden fazla ise "-" le ayrılmalı
Metin içerisinde yanışlıkla bitişik yazılmışlar seçilmez

Sub kalın()
If TextBox1.Value = "" Then Exit Sub
Dim s1 As Worksheet
Dim a As String, b As String
Dim j As Range, m As Long
Dim aa As String, x As Long, s As Long
Set s1 = Sheets("RAPOR")
a = Trim(TextBox1.Text)
For Each j In s1.Range("D16:D17")
b = Trim(j.Value)
For c = 0 To UBound(Split(a, "-"))
aa = Split(a, "-")(c)
x = Len(aa)
For s = 1 To Len(b) - x
m = 0
If Mid(b, s, x) = aa Then
If UBound(Split(Mid(b, s, x), " ")) = 0 Then
If s > 1 Then
If UBound(Split(Mid(b, s - 1, x), " ")) = 0 Then m = 1
End If
If s < Len(b) - x Then
If UBound(Split(Mid(b, s, x + 1), " ")) = 0 Then m = 1
End If
If m = 0 Then j.Characters(s, x).Font.Bold = True
End If: End If
Next
Next
Next
End Sub

 

[ormann]

Sayın Plint teşekkür ederim.Büyük küçük harf algılamıyor.Ayrıca şu şekilde de algılamıyor
Samsun ili Tekkeköy ilçesi Yazılar

 

[ormann]

Sayın Plint ayrı kelimelerde de bu işlemler olabilir mi?.Örneğin:
Samsun İli Tekkeköy İlçesi-117 Parsel-Orman Sayılan Yerlerden Olduğu şeklinde.
Ayrıca: Küçük büyük harfi algılamıyor.
örneğin: D1617 hücresinde samsun kelimesi varsa ben Samsun şeklinde yazarsam olmuyor.

 

[veyselemre]

Sub kalınYap()
    Set s1 = Sheets("RAPOR")
    s1.Range("D16:D17").Font.Bold = False
    If Right(s1.TextBox1.Text, 1) <> "-" Then s1.TextBox1.Text = s1.TextBox1.Text & "-"
    For Each bl In Split(s1.TextBox1.Text, "-")
        If bl <> "" Then
            bl = " " & Trim(WorksheetFunction.Proper(bl)) & " "
            For Each huc In s1.Range("D16:D17")
                j = " " & Trim(WorksheetFunction.Proper(huc.Value)) & " "
                For Each elem In Array(".", ",", ";", ":", "!", "?")
                    j = Replace(j, elem, " ")
                Next elem
                If InStr(j, bl) Then
                    say = (Len(j) - Len(Replace(j, bl, ""))) / Len(bl)
                    If say > 0 Then
                        bas = 1
                        For i = 1 To say
                            bul = InStr(bas, j, bl)
                            bas = bul + 1
                            huc.Characters(Start:=bul, Length:=Len(bl) - 1).Font.Bold = True
                        Next i
                    End If
                End If
            Next huc
        End If
    Next bl
End Sub