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 11-08-2017, 18:15   #11
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,339
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
objWord.ActiveDocument.Tables.Item(i).Cell(r, j).Range.HighlightColorIndex = wdPink
'objWord.ActiveDocument.Tables.Item(1).Cell(r, j).Shading.ForegroundPatternColor = wdColorAutomatic
'objWord.ActiveDocument.Tables.Item(1).Cell(r, j).Shading.BackgroundPatternColor = wdColorPink
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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 14-08-2017, 13:16   #12
biyoinforma
 
Giriş: 03/07/2017
Şehir: İstanbul
Mesaj: 11
Excel Vers. ve Dili:
Excel 2013
Varsayılan

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..

Bu mesaj en son " 14-08-2017 " tarihinde saat 13:17 itibariyle biyoinforma tarafından düzenlenmiştir.... Neden: güncelleme
biyoinforma Çevrimdışı   Alıntı Yaparak Cevapla
Eski 14-08-2017, 18:40   #13
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,339
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

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ı

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Microsoft Word 12.0 Object Library
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 15-08-2017, 13:21   #14
leumruk
Uzman
 
leumruk kullanıcısının avatarı
 
Giriş: 15/04/2007
Şehir: Mustafa ALTUN ANKARA
Mesaj: 3,116
Excel Vers. ve Dili:
Office 2010 & 2013 tr
Varsayılan

Alıntı:
biyoinforma tarafından gönderildi Mesajı Görüntüle
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.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
"Seni her türlü noksandan tenzih ederiz. Senin bize öğrettiğinden başka bizim hiçbir bilgimiz yoktur. Sen herşeyi hakkıyla bilir, her işi hikmetle yaparsın." (Bakara Sûresi: 2:32.)

"Onların duaları şu sözlerle sona erer: Ezelden ebede her türlü hamd ve övgü, şükür ve minnet, Âlemlerin Rabbi olan Allah'a mahsustur." (Yunus Suresi, 10:10.)
leumruk Çevrimdışı   Alıntı Yaparak Cevapla
Eski 16-08-2017, 20:15   #15
biyoinforma
 
Giriş: 03/07/2017
Şehir: İstanbul
Mesaj: 11
Excel Vers. ve Dili:
Excel 2013
Varsayılan

halit3 ve leumruk ilginiz ve desteğiniz için çok teşekkür ederim, sayenizde problemim çözüldü.
biyoinforma Ç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 03:17


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

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - investing - Hurda - Kozmetik Ürünler - Excel Eğitimi - Lingerie - Dyeing Machine - Çorlu Temizlik- Hazır Site- SEO- Çorlu Burun Estetiği- Karton Bardak- Çorlu Pimapenci- İstanbul Avukat- Çorlu Kekemelik- Edirne Su Arıtma- Çorlu Perde Yıkama- Marmara Ereğlisi Hotel- 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 Kamera- Çorlu Fiber- Çorlu Araç Takip-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden