Soru Satırlardaki belirli sözcüklerin biçimlerini değiştirme nasıl yapılır?

[assenucler]

Değerli Dostlar;


Hayırlı Cuma'lar.

Şu an,3000'e yakın satır büyüklüğündeki Excel dosyamın "B" sütununda, 8 punto Calibri olan aşağıdaki sözcükleri, makroyla büyük harf Calibri 14 punto kalın yapmak istiyorum. Çok özel bilgiler olduğundan dosyayı ekleyemedim.

Sözcükler: Arsu, Fara, Kasapoğlu, Komar, Maktek, Erdoğanlar, Vuraltaş, Yediyol, Konyapark, Mengir,Kilimoğlu, Vadi, Milan, Varant, Mefa, Onur, Hedef, Gözüpekoğulları, Üst Grup şeklindedir ve bu sözcüklere zaman zaman yeni eklemeler yapılabilmektedir.

Bul ve değiştir ile uğraşmama karşın, sağlıklı ve düzgün bir sonuç alamadım. Makro bilgim yok düzeyinde olduğu için, siz değerli gönül dostlarının yardımını rica ediyorum.

Saygılar.

 

[ismailozkan4224]

Sub SpecialCellMenu()
Dim cb As CommandBar
Set cb = Application.CommandBars("Cell")
'
Set MenuObject = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
MenuObject.Caption = "Harf Donustur..®"
MenuObject.BeginGroup = True
MenuObject.Tag = "MyTagR"
'
For MenuItem = 1 To 4
Set PopItem = MenuObject.Controls.Add(msoControlButton, 1, MenuItem, , True)
PopItem.FaceId = 7
With PopItem
Select Case MenuItem
Case 1
.Caption = "ABC DEF"
Case 2
.Caption = "Abc Def"
Case 3
.Caption = "abc def"
Case 4
.Caption = "Abc def"
End Select
.OnAction = "CaseChange"
End With
Next
Set cb = Nothing
Set PopItem = Nothing
Set MenuObject = Nothing
End Sub
Sub CaseChange()
Dim lngType As Long, MyRng As Range
Set MyWd = CreateObject("Word.Application")
Set MyDoc = MyWd.Documents.Add

Select Case CommandBars.ActionControl.Parameter
Case 1
lngType = 1
Case 2
lngType = 2
Case 3
lngType = 0
Case 4
lngType = 4
End Select

For Each MyRng In Selection
If (Not MyRng = Empty) And (Not IsNumeric(MyRng)) Then
MyWd.Selection.Text = MyRng.Text
MyWd.Selection.Range.Case = lngType
MyRng = MyWd.Selection.Text
End If
Next

MyDoc.Close False
MyWd.Quit
Set MyDoc = Nothing
Set MyWd = Nothing
End Sub
Sub YAZIMDÜZENİ()
Range("C4:C1000,I41000,S4:AO1000").Select
End Sub
Sub BUYUKHARFYAP()
Range("D41000,Q4:Q1000").Select
End Sub

 

[ismailozkan4224]

sayfanın kod bölümüne modüle yapıştır. mause un sağ klik olayında bir harf dönüştür diye bir menü göreceksin. ona tıkla açılan menüden istediğine uygun olanı seç. hepsi büyük harf, yazım düzeni, hepsi küçük harf vb. sonra stil ve puntoyu istediğin şekilde ayarlarsın

 

[assenucler]

Sayın ismailozkan4224,


Öncelikle ilginiz ve kodlar için teşekkürler.

Üstteki kodunuzu Excel Sayfa1 "kod görüntüle"'ye tıklayarak yapıştırdım. Açılan pencerede "Bir Harf Dönüştür" menüsü gözükmüyor. Sadece "BüyükHarfYap", "CaseChange", "SpecialCellMenu" ve "YAZIMDÜZENİ" var.

Düzeltme "B" sütununda yapılacak olmasına karşın, word'e ilişkin kodlar var. Kodlarda C ve D kolonu alan olarak gözüküyor.

Bilgisizliğimi mazur görün. Ancak bu kadar anlatabildim.

 

[assenucler]

İlk mesajımdaki konuya ilişkin küçük bir örnek Excel dosyasını ekliyorum.

 

[assenucler]

Dosyayı sonradan ekledim.

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu deneyiniz.

Sub kod()
sozcuk = Array("Arsu", "Fara", "Kasapoğlu", "Komar", "Maktek", "Erdoğanlar", "Vuraltaş", "Yediyol", "Konyapark", "Mengir", "Kilimoğlu", "Vadi", "Milan", "Varant", "Mefa", "Onur", "Hedef", "Gözüpekoğulları", "Üst Grup")
For Each soz In sozcuk
    Range("B:B").Replace soz, UCase(Replace(Replace(soz, "i", "İ"), "ı", "I")), xlPart
Next
For a = 1 To Cells(Rows.Count, "B").End(3).Row
    met = Cells(a, "B").Text
    For Each soz In sozcuk
        kac = InStr(1, met, UCase(Replace(Replace(soz, "i", "İ"), "ı", "I")))
        If kac > 0 Then
            With Cells(a, "B").Characters(Start:=kac, Length:=Len(soz)).Font
                .Name = "Calibri"
                .FontStyle = "Kalın"
                .Size = 14
            End With
        End If
    Next
Next
End Sub

 

[assenucler]

Sayın Ömer Bey,

Kodunuz çok güzel çalışıyor. Üstadım, uygun bir zamanınızda sizden bir ricada daha bulunabilir miyim?

Büyütülen firma adının, C sütununa da yazılması halinde, Veri Süz yaparak, seçilen firmaya ait tüm mesajları, aynı anda görebilmem mümkün olacaktır.

Koda nasıl bir ekleme yapmak gerekiyor?

İlginiz, yardımınız için teşekkür eder, her şeyin gönlünüzce olmasını dilerim.

Saygılar.

 

[ÖmerBey]

Buyurunuz.

If kac > 0 Then
            Cells(a, "C") = soz
            With Cells(a, "B")....

 

[assenucler]

Teşekkürler, sağ olun var olun.

 

[ÖmerBey]

Siz de sağ olun, iyi çalışmalar...