• DİKKAT

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

Word Dosyasında Aradığım Kriterleri Saydırmak

B

baysevimli

Katılım
13 Eylül 2015
Mesajlar
201
Excel Vers. ve Dili
2010 VBA
Merhaba Arkadaşlar,

Word dosyasın aşağıdaki kodları aratıp, o kodlardan kaçartane olduğunu saydırıp sonucu bir msgbox ile gösterebilir miyiz ?

Örneğin

aşağıdaki ilden sonra "B" ile başlayan kodlarımdan word dosyasında kaçta tane olduğunu arayacak ve bana msgbox ile bildirecek. Ancak saydıktan sonra aşağıda olduğu gibi verecek. örneğin "Ankara - B.02.2.CHY.0.10.01.53 / 5 Adet" gibi verecek.

Ankara - B.02.2.CHY.0.10.01.53
Antalya - B.02.2.CHY.0.18.03.54
Sivas - B.02.2.CHY.0.19.20.50
Mardin - B.02.2.CHY.0.09.01.52
İzmir - B.02.2.CHY.0.05.01.57

İlgi ve desteğiniz için şimdiden teşekkür ederim.
 
Kod: 
Sub aa()
ActiveDocument.Select
Metin = "Ankara - B.02.2.CHY.0.10.01.53#Antalya - B.02.2.CHY.0.18.03.54#Sivas - B.02.2.CHY.0.19.20.50#Mardin - B.02.2.CHY.0.09.01.52#İzmir - B.02.2.CHY.0.05.01.57"
Metin = Split(Metin, "#")
For i = 0 To UBound(Metin) - 1
MsgBox Metin(i) & " / " & UBound(Split(Selection, Metin(i))) & " Adet"
Next
End Sub
 
Sn. alicimri

Test ettim çalıştı. Çok teşekkür ederim. Ancak bi ricam daha var.

Düşündümde Bu kodları excel ile saydırmak istiyorum. Benim için daha pratik olacak. Yukarıdaki gibi bütün kodlarımı exceldeki "sayfa1" sheetimde "B" sütununa yazsam ve "C:\New folder\dosya " adres yolundaki word dosyamda arayıp exceldeki "Sayfa2" sheetime sayfa1 de aradığı ve sadece bulduğu kodları "A", "B" ve "C"sütununa kaç adet olduğunu yazdırabilir miyiz. Örnek dosyam ektedir.

Teşekkür ederim.
 

Ekli dosyalar

Kod: 
Sub saydir()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("a2:C1000").ClearContents
say = s1.Range("A" & Cells.Rows.Count).End(3).Row
Set doc = CreateObject("Word.Document")
doc.Application.documents.Open "D:\dene.doc"
doc.Application.ActiveDocument.Select
yaz = 2
For i = 2 To say
bul = s1.Range("A" & i) & " - " & s1.Range("B" & i)
If UBound(Split(doc.Application.Selection, bul)) <> 0 Then
s2.Range("A" & yaz).Value = s1.Range("A" & i)
s2.Range("B" & yaz).Value = s1.Range("B" & i)
s2.Range("C" & yaz).Value = UBound(Split(doc.Application.Selection, bul))
yaz = yaz + 1
End If
Next
doc.Application.ActiveDocument.Close
Set doc = Nothing
End Sub
 
Son düzenleme:
Kusura bakmayın ben anlatamadım. Tekrar özetliyeyim. Şimdi,

Bir önceki mesajda gönderdiğim excel'de "sayfa1" ve "sayfa2" adında iki sheet'im var.

1-"Sayfa1" sheet'imde A sütununda il , B sütunumdai ise kod bilgilerim var. Bu bilgiler benim sabit datam olacak. Bu arada ben A ve B sütunlarında size birkaç örnek verdim ama benim elimde 250 den fazla kod var.
2-"Sayfa2" sheetimde ise A sütununda il, B sütununda kod ve C sütununda adet isimli başlık açtım.istediğimde şu;

Makro gidecek C:\New folder\dosya yolunda bulunan word dosyamın içinde sayfa1 sheetimde B sütununda bulunan tüm kodları arayıp sayacak bulduklarını ise Sayfa2 sheetine Alt alta yazacak. Tabi bulduğu kodları yazarken o kodun ilini ve adedini de yazacak. Zaten sayfa2 sheetimide o sebeple boş bıraktım. Bulamadığı kodları sayfa2 ye atmayacak. Bu sayede msgboxa ihtiyaç olmayacak.
 
#4 nolu mesajdaki kodları yeniledim. Dosya yolu ve adını kendinize uyarlayın.
 
#4 nolu mesajdaki kodları tekrar yeniledim. "Bulamadığı kodları sayfa2 ye atmayacak" konusunu unutmuşum.
 
merhaba alicimri

Test ettim ancak aşağıdaki hatayı aldım.

Run-time error '5174':

Application-defined or object-defined error

Bu arada benim word uzantım .doc değil, .docx
 
Dosya yolunu, adını ve uzantısını kendinize uyarlayın. Bu hatayı hangi satırda veriyor.
 
alicimri' Alıntı:
Dosya yolunu, adını ve uzantısını kendinize uyarlayın. Bu hatayı hangi satırda veriyor.
Genişletmek için tıkla ...

Kendime göre uyarladım ama aşağıdaki satırda veriyor hatayı.

doc.Application.documents.Open "D:\karar.doc"
doc.Application.ActiveDocument.Select
 
Son düzenleme:
"D:\karar.doc" benim dosyamın uzantısı "docx" diyorsunuz, "doc" yazmışsınız, "C:\New folder\dosya " diye daha önce dosya yolu vermişsiniz "D:/" yi kullanmışınız.
 
Sn. Alicimri,

Kodu aşağıdaki gibi revize ettim. Ancak,

Run-time error '-2147417848 (80010108)':

Automation error

hatasını veriyor.

hatayı ise

doc.Application.ActiveDocument.Select

satırında veriyor. Bu satırı pasif yaptığımda ise

If UBound(Split(doc.Application.Selection, bul)) <> 0 Then

satırında aynı hatayı veriyor.



Kod: 
Sub saydir()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("a2:C1000").ClearContents
say = s1.Range("A" & Cells.Rows.Count).End(3).Row
Set doc = CreateObject("Word.Document")
doc.Application.documents.Open "D:\New folder\karar.docx"
doc.Application.ActiveDocument.Select
yaz = 2
For i = 2 To say
bul = s1.Range("A" & i) & " - " & s1.Range("B" & i)
If UBound(Split(doc.Application.Selection, bul)) <> 0 Then
s2.Range("A" & yaz).Value = s1.Range("A" & i)
s2.Range("B" & yaz).Value = s1.Range("B" & i)
s2.Range("C" & yaz).Value = UBound(Split(doc.Application.Selection, bul))
yaz = yaz + 1
End If
Next
doc.Application.ActiveDocument.Close
Set doc = Nothing
End Sub
 
Peki şöyle yapalım. Excel dosyası ile Word dosyasını aynı klasöre koyun, yan yana aşağıdaki kodu deneyin.
Kod: 
doc.Application.documents.Open ThisWorkbook.Path & "/karar.docx"
 
Excel ve Word dosyamı yan yana koydum ve aşağıdaki kodlar ile test ettim. Bu sefer aşağıdaki satırda hata verdi. Hata görüntüsü ektedir.

If UBound(Split(doc.Application.Selection, bul)) <> 0 Then


Kod: 
Sub saydir()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("a2:C1000").ClearContents
say = s1.Range("A" & Cells.Rows.Count).End(3).Row
Set doc = CreateObject("Word.Document")
doc.Application.documents.Open ThisWorkbook.Path & "/karar.docx"
doc.Application.ActiveDocument.Select
yaz = 2
For i = 2 To say
bul = s1.Range("A" & i) & " - " & s1.Range("B" & i)
If UBound(Split(doc.Application.Selection, bul)) <> 0 Then
s2.Range("A" & yaz).Value = s1.Range("A" & i)
s2.Range("B" & yaz).Value = s1.Range("B" & i)
s2.Range("C" & yaz).Value = UBound(Split(doc.Application.Selection, bul))
yaz = yaz + 1
End If
Next
doc.Application.ActiveDocument.Close
Set doc = Nothing
End Sub
 

Ekli dosyalar

  • Capture.JPG
    Capture.JPG
    11.8 KB · Görüntüleme: 7
Gidip 2007 yüklü PC de denedim, kodlar çalışıyor. Sorunu anlayamadım, kusura bakmayın.
 
Sn. Alicimri ilginiz için çok teşekkür ederim.

Değerli üstadlar konu günceldir. Çözüm için yardımlarınızı bekliyorun.
 
Benim pc de office 2010 yüklü, kodları başka bir 2010 office yüklü pc'de de denedim sonuç alamadım.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst