• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Uzun metinlerde tırnak içinde olan kelime/cümleleri tek seferde italik yapmak

  • Konbuyu başlatan Konbuyu başlatan ilmtrz
  • Başlangıç tarihi Başlangıç tarihi
I

ilmtrz

Katılım
27 Aralık 2012
Mesajlar
245
Excel Vers. ve Dili
Excel 2019
Merhaba, uzun bir metinle çalışmaktayım. Metin içinde çok sayıda tırnak içinde kelime veya cümleler var. Amacım bu kelime veya cümleleri italik yapmak. Bunu tek tek seçerek italik yapıyorum ama işlem çok uzun sürüyor. Sormak istediğim bu metnin içinde tırnak içinde yer alan kelime/cümleleri tek seferde seçip italik yapabilir miyim?
 
Örnek bir dosya eklerseniz çözüm kolaylaşır.
 
Ekte bulunan makro içeren dosyasını kullanarak gelecek dosya seçim diyaloğıyla word dosyasını seçin ve bekleyin. İşlem yaklaşık 1 dk. sürmekte.

Normalde wordde joker karakter ile bulunabiliyor olsa da, alakasız yerleri de bulmakta. Bu nedenle regular expression yöntemi daha etkilidir.

Çok uzun cümle ve paragraflar worddeki bul kutusunun karakter sınırlaması olduğundan bulunamamaktadır. Bunları program çalışması bittikten sonra masaüstündeki "ErrorLOG.txt" dosyasında görebilirsiniz. Bunları elle bulup düzeltmeniz gerekiyor.

Sonuçları görmeniz için bulunanları renklendirdim. Bir tutarsızlık varsa bildirin.

Başlamadan önce word dosyanızın bir yedeğini alın.

Kod: 
[SIZE=2]Sub Bul_Degistir()
    On Error Resume Next
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
    fd.Filters.Clear
    fd.Filters.Add "MS Word Dosyaları (*.docx)", "*.docx", 1
    ret = fd.Show
    
    If Not ret = -1 Then Exit Sub
    
    fn = fd.SelectedItems(1)
    
    Set wApp = CreateObject("Word.Application")
    
    wApp.Visible = True
    
    wApp.Documents.Open fn
    
    txt = wApp.ActiveDocument.Content.Text
    
    Set reg = CreateObject("VBScript.RegExp")
    
    reg.Global = True
    reg.MultiLine = True
    reg.Pattern = Chr(147) & ".*?" & Chr(148) & "|\s"".*?""\s|\s"".*?""|"".*?""\s"
    
    Set col = reg.Execute(txt)
    
    Open Environ("userprofile") & "\Desktop\ErrorLOG.txt" For Output As #1
    Print #1, "AŞAĞIDAKİLER DEĞİŞTİRİLEMEDİ!!!"
    Print #1, ""
    Print #1, ""
    
    For i = 0 To col.Count - 1
        
        wApp.ActiveDocument.Range(0, 0).Select
        
        wApp.Selection.Find.ClearFormatting
        
        With wApp.Selection.Find
            .Text = col(i)
            .Forward = True
            .Wrap = 1 ' wdFindContinue
            .Format = False
            .MatchCase = True
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        
        If Err Then
            Print #1, "Değiştirilemedi -- " & col(i)
            Print #1, ""
            Err.Clear
        End If
        
        wApp.Selection.Find.Execute
        wApp.Selection.Font.Italic = True
        wApp.Selection.Font.TextColor = vbRed ' Bu satır sonra silinecek.
       
    Next
    
    Close #1
    
    MsgBox "İşlem tamamlandı." & vbCrLf & "Toplam : " & col.Count & " adet bulundu." & vbCrLf & _
           "Ancak çok uzun cümleler değiştirilememiş olabilir." & vbCrLf & _
           Environ("userprofile") & "\Desktop\ErrorLOG.txt dosyasına bakın." & vbCrLf & _
           "Kontrol etmeyi unutmayın.", vbInformation, "Zeki"
    
    CreateObject("Shell.Application").Open Environ("userprofile") & "\Desktop\ErrorLOG.txt"
End Sub[/SIZE]
 

Ekli dosyalar

Merhaba Zeki Bey, ilginiz için teşekkür ederim. Önce ekte gönderdiğiniz dosyayı çalıştırdım. İşlem bitti. Tırnak içinde olan kelime/cümleler kırmızı ve italik oldu. İstenilen sonuç buydu.

Daha sonra "ErrorLOG.txt" dosyasındaki değiştirilemeyen yerleri bulup elle düzelttim ve yeşile boyadım. Buna göre tırnak içinde olan kelime/cümleler kırmızı ve yeşil oldular.

Ancak belgeyi baştan kontrol ettiğimde tırnak içinde olan bazı kelime/cümlelerin değişmediğini gördüm. Bunların bazılarını elle seçip maviye boyadım. Bu haldeki dosyayı ekte gönderiyorum.
 

Ekli dosyalar

  • KDV2.rar
    KDV2.rar
    312.7 KB · Görüntüleme: 10
Tekrar merhaba;

Bahsettiğiniz problem giderildi. Değiştirilemeyen cümleler çok fazla olursa vba ile manuel aratma yoluna gidilebilir. Ancak Word VBA kitaplığına hakim olmadığımdan bu konuya şimdi bakmayacağım. Şimdilik elle düzelterek idare edin.

Excel dosyasındaki kodu tamamen silerek aşağıdaki kodu yapıştırın.

Kod: 
[SIZE=2]Sub Bul_Degistir()
    On Error Resume Next
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
    fd.Filters.Clear
    fd.Filters.Add "MS Word Dosyaları (*.docx)", "*.docx", 1
    ret = fd.Show
    
    If Not ret = -1 Then Exit Sub
    
    fn = fd.SelectedItems(1)
    
    Set wApp = CreateObject("Word.Application")
    
    wApp.Visible = True
    
    wApp.Documents.Open fn
    
    txt = wApp.ActiveDocument.Content.Text
    
    Set reg = CreateObject("VBScript.RegExp")
    
    reg.Global = True
    reg.MultiLine = True
    reg.Pattern = Chr(147) & ".*?" & Chr(148) & "|\s"".*?""\s|\s"".*?""|"".*?""\s"
    
    Set col = reg.Execute(txt)
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    For i = 0 To col.Count - 1
        If Not dic.Exists(CStr(col(i))) Then _
            dic.Add CStr(col(i)), col(i)
    Next
    
    Open Environ("userprofile") & "\Desktop\ErrorLOG.txt" For Output As #1
    Print #1, "AŞAĞIDAKİLER DEĞİŞTİRİLEMEDİ!!!"
    Print #1, ""
    Print #1, ""
    
    For i = 0 To dic.Count - 1
        DoEvents
        wApp.ActiveDocument.Range(0, 0).Select
        
        wApp.Selection.Find.ClearFormatting
        
        With wApp.Selection.Find
            .Text = dic.Items()(i)
            .Forward = True
            .Wrap = 1 ' wdFindContinue
            .Format = False
            .MatchCase = True
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        
        If Err Then
            s = s + 1
            Print #1, s; " -- "; dic.Items()(i)
            Print #1, ""
            Err.Clear
        End If
        
        Do
            DoEvents
            wApp.Selection.Find.Execute
            If wApp.Selection.Find.found = False Then Exit Do
            wApp.Selection.Font.Italic = True
            wApp.Selection.Font.TextColor = vbRed ' Bu satır sonra silinecek.
        Loop
       
    Next
    
    Close #1
    
    MsgBox "İşlem tamamlandı." & vbCrLf & "Toplam : " & col.Count & " adet bulundu." & vbCrLf & _
           "Ancak çok uzun cümleler değiştirilememiş olabilir." & vbCrLf & _
           Environ("userprofile") & "\Desktop\ErrorLOG.txt dosyasına bakın." & vbCrLf & _
           "Kontrol etmeyi unutmayın.", vbInformation, "Zeki"
    
    CreateObject("Shell.Application").Open Environ("userprofile") & "\Desktop\ErrorLOG.txt"
End Sub[/SIZE]
 
Teşekkür ederim Zeki bey, büyük oranda işim görüldü. Geri kalan kısmını elle düzelttim. Tekrar teşekkürler.
 
Font türü ve font büyüklüğünü siz kendinize göre değiştirin, alternatif kodlar aşağıda Dosyanızı yedekleyin.
Kod: 
Sub Makro1()
ActiveDocument.Select
 CommandBars("Navigation").Visible = False
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = """"
        .Replacement.Text = "#"
    End With
   Selection.Find.Execute Replace:=wdReplaceAll
a = Split(Selection, "#")
say = UBound(a)
Selection.Delete
For i = 0 To say
 Selection.Font.Name = "Arial"
    Selection.Font.Size = 12
If i Mod 2 = 1 Then
 Selection.Font.Italic = wdToggle
Selection.TypeText Text:="""" & a(i) & """"
 Selection.Font.Italic = wdToggle
 Else
 Selection.TypeText Text:=a(i)
End If
Next
End Sub
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst