Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > Diğer Yazılımlar > Windows-Word-PowerPoint....
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Windows-Word-PowerPoint.... Excel haricindeki Ofis programları ile ilgili konular.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 14-01-2017, 23:50   #1
ilmtrz
Altın Üye
 
Giriş: 27/12/2012
Şehir: BURSA
Mesaj: 226
Excel Vers. ve Dili:
excel 2013
Varsayılan Uzun metinlerde tırnak içinde olan kelime/cümleleri tek seferde italik yapmak

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?
ilmtrz Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-01-2017, 00:16   #2
Zeki Gürsoy
Uzman
 
Zeki Gürsoy kullanıcısının avatarı
 
Giriş: 31/12/2005
Şehir: Sakarya-Hendek
Mesaj: 3,353
Excel Vers. ve Dili:
Office 2016 (x64) - Türkçe
Varsayılan

Örnek bir dosya eklerseniz çözüm kolaylaşır.
__________________

gursoyzeki@gmail.com




Zeki Gürsoy Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-01-2017, 00:29   #3
ilmtrz
Altın Üye
 
Giriş: 27/12/2012
Şehir: BURSA
Mesaj: 226
Excel Vers. ve Dili:
excel 2013
Varsayılan

İyi geceler Zeki Bey, örnek dosyayı ekledim. Dosyada tırnak içinde olan kelime/cümlelerden birkaçını elle yaptım.

Alıntı:
Zeki Gürsoy tarafından gönderildi Mesajı Görüntüle
Örnek bir dosya eklerseniz çözüm kolaylaşır.
Eklenmiş Dosyalar
Dosya Türü: rar KDV.rar (308.8 KB, 17 Görüntülenme)
ilmtrz Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-01-2017, 11:52   #4
Zeki Gürsoy
Uzman
 
Zeki Gürsoy kullanıcısının avatarı
 
Giriş: 31/12/2005
Şehir: Sakarya-Hendek
Mesaj: 3,353
Excel Vers. ve Dili:
Office 2016 (x64) - Türkçe
Varsayılan

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
Eklenmiş Dosyalar
Dosya Türü: xlsm word.xlsm (22.0 KB, 6 Görüntülenme)
__________________

gursoyzeki@gmail.com




Zeki Gürsoy Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-01-2017, 13:22   #5
ilmtrz
Altın Üye
 
Giriş: 27/12/2012
Şehir: BURSA
Mesaj: 226
Excel Vers. ve Dili:
excel 2013
Varsayılan

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.
Eklenmiş Dosyalar
Dosya Türü: rar KDV2.rar (312.7 KB, 10 Görüntülenme)
ilmtrz Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-01-2017, 20:02   #6
Zeki Gürsoy
Uzman
 
Zeki Gürsoy kullanıcısının avatarı
 
Giriş: 31/12/2005
Şehir: Sakarya-Hendek
Mesaj: 3,353
Excel Vers. ve Dili:
Office 2016 (x64) - Türkçe
Varsayılan

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________

gursoyzeki@gmail.com




Zeki Gürsoy Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-01-2017, 20:53   #7
ilmtrz
Altın Üye
 
Giriş: 27/12/2012
Şehir: BURSA
Mesaj: 226
Excel Vers. ve Dili:
excel 2013
Varsayılan

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.
ilmtrz Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-02-2017, 08:13   #8
alicimri
 
Giriş: 12/12/2015
Mesaj: 381
Excel Vers. ve Dili:
Ofis 2003
Varsayılan

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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

Bu mesaj en son " 21-02-2017 " tarihinde saat 22:30 itibariyle alicimri tarafından düzenlenmiştir....
alicimri Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 13:09


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet- Çorlu Prefabrik- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri- Çorlu Çelik Konstruksiyon-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden