Word'da Kriter Saydırma

[baysevimli]

Arkadaşlar Merhaba,
Aşağıdaki kod dizinleri ile Word dokümanımda bazı yerlere otomatik sayı verdiriyorum. Şuan işimi görüyor bu kodlar. Kod dizininin altında ise dikkat ettiyseniz Word dokümanımda kaç tane “.TEKLF” ve “KARAR NO:” varsa saydırıp ve msgbox da göster diyorum. Şimdi istediğim şu; msgbox da bunlara ilave olarak dokümanda kaçta ne “İcra” , “Yönetim” , “Denetim” ve “Hukuk” ibareleri varsa saysın onların adedini de msgbox da göstersin istiyorum. İlginiz için teşekkür ederim.



Sub Makro1()
'baysevimli
Dim InitialDecisionNo As Integer
Dim InitialDecisionStr As String

InitialDecisionNo = 1

ActiveDocument.Select
Selection.HomeKey unit:=wdStory

Selection.Find.Text = "KARAR NO:"
Selection.Find.Execute
With Selection
.Collapse Direction:=wdColl
.ColumnSelectMode = True
.MoveLeft unit:=wdWord, Count:=-2, Extend:=wdExtend
.ColumnSelectMode = False
End With


InitialDecisionStr = Replace(Selection.Range.Text, " ", "")

If Not InitialDecisionStr = "" Then
InitialDecisionNo = CInt(Selection.Range.Text)
End If


ActiveDocument.Select
ab = Split(Selection, "KARAR NO:")
say = UBound(ab) + (InitialDecisionNo - 1)
Selection.HomeKey unit:=wdStory

For i = InitialDecisionNo To say
Selection.Find.Text = "KARAR NO:"
Selection.Find.Execute
With Selection
.Collapse Direction:=wdColl
.ColumnSelectMode = True
.MoveLeft unit:=wdWord, Count:=-2, Extend:=wdExtend
.ColumnSelectMode = False
End With
Selection.Range.Text = i & vbTab
Selection.Find.Execute
x = x + 1
Next


ActiveDocument.Select
ab = Split(Selection, ".TEKL" & ChrW(&H130) & "F")
say2 = UBound(ab)
Selection.HomeKey unit:=wdStory
For i = 1 To say2
Selection.Find.Text = ".TEKL" & ChrW(&H130) & "F"
Selection.Find.Execute
With Selection
.Collapse Direction:=wdCollapseStart
.ColumnSelectMode = True
.MoveRight unit:=wdWord, Count:=-1, Extend:=wdExtend
.ColumnSelectMode = False
End With
Selection.Range.Text = i
Selection.Find.Execute
y = y + 1
Next

MsgBox "Merhaba ! Bitti." & vbCrLf & x & " adet Karar No" & vbCrLf & _
y & " adet Teklif No "
End Sub

 

[ÖmerBey]

Merhaba,
Kodunuzun son kısmını aşağıdaki şekilde değiştiriniz.

Next

klm = Array("İcra", "Yönetim", "Denetim", "Hukuk")
txt = ActiveDocument.Content.Text
For Each k In klm
    t = Split(txt, k)
    met = met & vbLf & UBound(t) & " adet " & k
Next

MsgBox "Merhaba ! Bitti." & vbCrLf & x & " adet Karar No" & vbCrLf & _
y & " adet Teklif No " & met
End Sub

 

[baysevimli]

Ömer bey öncelikle desteğiniz için teşekkür ederim. Kod çalışıyor ancak şöyle bi sorunum var. Ben aradığım kriteri "yukarıda zikredilen" şeklinde yazıyorum ama kod çalışınca "yukaryda zikredilen" şeklinde arıyor ve dolayısıyla bulamıyor. Yani türkçe karekterle aramıyor. Tools/options/editor format kısmında normal text ve calibri türkçe ayarlarım seçili. Ona rağmen böyle. Çözemedim.

 

[ÖmerBey]

Bilgisayarın Bölge ve Dil ayarlarından aşağıdaki ayarı deneyiniz...

 

[baysevimli]

Ömer bey,

Oldu. Teşekkür ederim.

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar...