satır renklendirme

[biyoinforma]

Merhaba,

Word' de oluşturduğum 100 sayfalık tablolar var. Bu tablolar içerisinde belli kelimelerin olduğu satırları renklendirmek istiyorum. Örnek: "kalem" kelimesini içeren satırlar kırmızı olsun gibi. Bul-Değiştir yolunu takıip ettim, ancak orada sadece yazının rengi değişiyor.

Bunları exceldeki gibi toplu bir şekilde renklendirmem mümkün mü?

Teşekkürler

 

[halit3]

Bir örnek dosya ekleyin ne yapılacağını görelim.

 

[biyoinforma]

Merhaba,

Dosya aşağıdaki bağlantıda yer almakta.
Teşekkürler

http://s9.dosya.tc/server3/1sxca9/kalem.docx.html

 

[halit3]

dosya inmiyor yeniden yükleyiniz

 

[leumruk]

Selamlar,
Aşağıdaki kodu, dosyanızın makro bölümüne kopyalayın ve çalıştırın.

Sub dene()
sor = InputBox("Aranacak metni yazınız...", "Metin Arama")
If sor = "" Then Exit Sub

For Each tbl In ActiveDocument.Tables
    For Each rw In tbl.Rows
        For Each hcr In rw.Cells
        txt = Mid(hcr, 1, Len(hcr) - 2)
        If InStr(1, txt, sor) > 0 Then
            rw.Shading.ForegroundPatternColor = wdColorAutomatic
            rw.Shading.BackgroundPatternColor = wdColorRed
        End If
        Next
    Next
Next
MsgBox "İşlem tamamlandı.", vbOKOnly, "leumruk"
End Sub

 

[biyoinforma]

Lemruk selam,

Verdiğin kod işe yaradı, ama sadece "kalem" yazan satırı değil aynı sıradaki tüm satırlar da kırmızı oluyor. Bunu nasıl düzeltebiliriz?

 

[leumruk]

Siz kalem yazan hücrenin mi renklenmesini istiyorsunuz?

 

[halit3]

3 nolu mesajınızdaki dosya linki bende indirmiyor hayret ama 10 kere indirildi uyarısı veriyor.

 

[biyoinforma]

Lemruk, evet sadece kalem yazan satırın renklenmesini istiyorum. Örnek dosyada diğer satırlar boş görünüyor, ama asıl dosyada boş olan satırlarda dolu ve onları da farklı renklendireceğim.

Halit3 indirmede bir sıkıntı yok gibi duruyor.

 

[leumruk]

Sanırım, satırla kastettiğiniz, metnin bulunduğu hücre. Eğer öyle ise aşağıdaki kodu deneyiniz.

Sub dene()
sor = InputBox("Aranacak metni yazınız...", "Metin Arama")
If sor = "" Then Exit Sub

For Each tbl In ActiveDocument.Tables
    For Each rw In tbl.Rows
        For Each hcr In rw.Cells
        txt = Mid(hcr, 1, Len(hcr) - 2)
        If InStr(1, txt, sor) > 0 Then
            hcr.Shading.ForegroundPatternColor = wdColorAutomatic
            hcr.Shading.BackgroundPatternColor = wdColorRed
        End If
        Next
    Next
Next
MsgBox "İşlem tamamlandı.", vbOKOnly, "leumruk"
End Sub

 

[halit3]

Dosyayı vürüs proğramını kapattıktan sonra nihayet indirdim alternatif olarak kod

Sub tablo_word8()

'referanslar bölümünde aşağıdaki prosüdür olmalı
'Microsoft Word 12.0 Object Library

aranan = InputBox("Aran sözcüğü yazın", "UYARI", "kalem") ' aranan kelime
If aranan = "" Then Exit Sub


Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim objDialog, intResult
Set objDialog = CreateObject("MSComDlg.CommonDialog")
objDialog.Flags = 4
'objDialog.Filter = "DosyalarExcel Files (.doc)|*.doc"
objDialog.Filter = "Tüm Dosyalar(*.*)|*.*|Excell Files (*.xls*)|*.xls*|MSWord Files (*.doc)|*.doc|PDF Files (*.pdf)|*.pdf|Metin Files (*.txt*)|*.txt*"
objDialog.FilterIndex = 3
objDialog.InitDir = ThisWorkbook.Path
objDialog.ShowOpen
intResul = objDialog.Filename
If Len(intResul) = 0 Then

MsgBox "Dosya seçmediniz.", vbInformation + vbCritical
Exit Sub
Set objDialog = Nothing

Else
yol = objDialog.Filename

Dim objWord As Word.Application
Dim docWord As Word.Document

Set objWord = CreateObject("Word.Application")
objWord.Visible = True

Set docWord = objWord.Documents.Open(Filename:=yol, Visible:=True)

If objWord.ActiveDocument.Tables.Count > 0 Then
For i = 1 To objWord.ActiveDocument.Tables.Count
For r = 1 To objWord.ActiveDocument.Tables(i).Rows.Count
sat = sat + 1
For j = 1 To objWord.ActiveDocument.Tables(i).Rows(r).Cells.Count
deg1 = LCase(Replace(Trim(Trim(objWord.ActiveDocument.Tables.Item(i).Cell(r, j).Range.Text)), Chr(13), ""))
If deg1 Like "*" & Trim(LCase(aranan)) & "*" & "*" = True Then
[COLOR="Blue"]objWord.ActiveDocument.Tables.Item(i).Cell(r, j).Range.HighlightColorIndex = wdPink[/COLOR]
[COLOR="Red"]'objWord.ActiveDocument.Tables.Item(1).Cell(r, j).Shading.ForegroundPatternColor = wdColorAutomatic
'objWord.ActiveDocument.Tables.Item(1).Cell(r, j).Shading.BackgroundPatternColor = wdColorPink[/COLOR]
End If
Next j
Next r

Next i
End If

docWord.Close (Word.WdSaveOptions.wdSaveChanges)
objWord.Quit
Set docWord = Nothing
MsgBox "işlem tamam"

End If
Set objDialog = Nothing

End Sub

not. hücreyi renklendirecekseniz mavi bölümü silip kırmızı bölümü aktif yapın

 

[biyoinforma]

leumruk çok teşekkür ederim, tam istediğim gibi oldu.
Başka hücrelerdeki kelimeleri de renklendirmek istiyorum (toplam 10 renk), bu kodu ayrı bir makro olarak kaydedip ayrı ayrı mı çalıştırmalıyım yoksa sizin kodun devamına yazabilir miyiz?

halit3 ilgin ve desteğin için çok teşekkür ederim, ancak kodları çalıştıramadım hata veriyor..

 

[halit3]

Yukarıdaki mesajdaki kodu bir excel dosyası nın için (modüle) kopyalayın. Kodu excelde çalıştıracaksınız.

Kodun başında referanlarla ilgili bölüm vardı.

referanslar bölümünde aşağıdaki prosüdür olmalı

Microsoft Word 12.0 Object Library

 

[leumruk]

leumruk çok teşekkür ederim, tam istediğim gibi oldu.
Başka hücrelerdeki kelimeleri de renklendirmek istiyorum (toplam 10 renk), bu kodu ayrı bir makro olarak kaydedip ayrı ayrı mı çalıştırmalıyım yoksa sizin kodun devamına yazabilir miyiz?

İsteğiniz değişik şekillerde yapılabilir. Fikir vermesi açısından bir kod hazırladım. Aşağıdaki kodu deneyiniz.

Sub dene()
sor = InputBox("Aranacak metni yazınız...", "Metin Arama")
If sor = "" Then Exit Sub
renk = "1-Black" & Chr(10) & " 2-Blue" & Chr(10) & " 3-Cyan" & Chr(10) & " 4-Green" & Chr(10) & " 5-Magenta" & Chr(10) & " 6-Red" & Chr(10) & " 7-Yellow" & Chr(10) & " 8-White" & Chr(10) & " 9-Dark Blue" & Chr(10) & " 10-Dark Cyan" & Chr(10) & " 11-Dark Green" & Chr(10) & " 12-Dark Magenta" & Chr(10) & " 13-Dark Red" & Chr(10) & " 14-Dark Yellow" & Chr(10) & " 15-Dark Gray" & Chr(10) & " 16-Light Gray"
tekrar:
        renksor = InputBox("Renk girişi yapınız... Giriş yapmazsanız kırmızı seçilecektir." & Chr(10) & renk, "RENK SEÇİMİ")
        If renksor = "" Then renksor = 6
        If renksor > 16 Or IsNumeric(renksor) = False Then
        MsgBox "Geçersiz bir işlem yaptınız. Girdiğiniz verinin 1-16 arasında sayısal bir değer olmasına dikkat ediniz.", vbInformation, "UYARI"
        GoTo tekrar
        End If

For Each tbl In ActiveDocument.Tables
    For Each rw In tbl.Rows
        For Each hcr In rw.Cells
        txt = Mid(hcr, 1, Len(hcr) - 2)
        If InStr(1, txt, sor) > 0 Then
            hcr.Shading.ForegroundPatternColor = wdColorAutomatic
            hcr.Shading.BackgroundPatternColorIndex = renksor
        End If
        Next
    Next
Next
MsgBox "İşlem tamamlandı.", vbOKOnly, "leumruk"
End Sub

 

[biyoinforma]

halit3 ve leumruk ilginiz ve desteğiniz için çok teşekkür ederim, sayenizde problemim çözüldü.