Word Dosyasında Otomatik Sıralama

[baysevimli]

Değerli Arkadaşlar Merhaba,

Ekli dosyada upload ettiğim örnek Word dosyasında 4 hikâye metnim var. Her hikaye metninin sağında Teklif numarası ve Karar numarası var. Ben size pratik olması sebebiyle 4 hikaye metni verdim. Benim bazen 100-1500 metnim olabiliyor. İstediğim iki şey var.

1 - Word dosyasında Sağdaki Teklif numaralarını en baştan aşağıya doğru sıralı otomatik yazsın; örneğin 1.Teklif, 2. Tekif, 3.Teklif ….. şeklinde. Ama burada önemli bir nokta var bazen ortalardan bir hikayeyi silebiliyorum sildiğim zamanda otomatik yine en baştan başlayarak sıra numarası versin.

2- Yine Word dosyasında Sağdaki Karar No kısımlarını da en baştan aşağıya doğru sıralı numara verecek ama burda da önemli olan şu; en baştan sıralamaya 1,2,3,4,5 diye başlamayacak, benim verdiğim numaradan sonra başlayacak örneğin 0890 numarasını bir alana yazıcam otomatik olarakta kaçtane teklif varsa karar numaralarını 0890 dan başlayarak sıralı numara verecek. Bir önemli nokta daha var ortalardan teklif metni sildiğimde yine sıralamayı otomatik yapacak. Yardımlarınız için teşekkür ederim.

örnek dosya linki aşağıdaki gibidir.

http://s4.dosya.tc/server/6i9z76/Ornek_Calisma_Dosyasi.docx.html

 

[Asri]

Dosya içindeki menu makrosunu çalıştırınız.
Karar için, program ilk karar numarasına bakacaktır.
İlk numarayı birer arttıracak.

Teklif lerde ise 1 den başlayacaktır.

http://s5.dosya.tc/server/g83s6l/Ornek_Calisma_Dosyasi.zip.html

Sub Menu()
   Call karar_duzenle
   Call teklif_duzenle
End Sub

Sub karar_duzenle()
  Dim strCellText As String
  Dim uResp As String
  Dim Row As Integer
  Dim Col As Integer
  Dim itable As Table
  say = 0
  For Each itable In ThisDocument.Tables
    karar = ""
    For Row = 1 To itable.Rows.Count
       For Col = 1 To itable.Columns.Count
            kararnumarasi = 0
            karar = ""
            cumle = itable.Cell(Row, Col).Range.Text
            If InStr(cumle, ":") > 0 Then
               kararnumarasi = Val(Mid(cumle, InStr(cumle, ":") + 1, Len(cumle)))
               karar = Mid(cumle, 1, InStr(cumle, ":"))
            End If
            If karar = "KARAR NO:" Then
               If say = 0 Then
                  numarator = kararnumarasi
               Else
                numarator = numarator + 1
                  itable.Cell(Row, Col).Range.Text = "KARAR NO:" & numarator
               End If
               say = say + 1
            End If
       Next
    Next
  Next

End Sub

  
Sub teklif_duzenle()
   Dim strLine As String
   Dim colString As Collection
   Dim intLastLine As Integer
   Dim intLastPage As Integer
   Dim flag As Boolean
   On Error Resume Next
   
   Selection.EndKey Unit:=wdStory
   intLastLine = Selection.Range.Information(wdFirstCharacterLineNumber)
   intLastPage = Selection.Range.Information(wdActiveEndPageNumber)
   
   Set colString = New Collection
   Selection.HomeKey Unit:=wdStory
   flag = True
   While flag = True
     If (Selection.Range.Information(wdFirstCharacterLineNumber) _
         = intLastLine) And intLastPage = _
        Selection.Range.Information(wdActiveEndPageNumber) Then
        flag = False
     End If
     
     Selection.EndKey Unit:=wdLine, Extend:=wdExtend
     cumle = Selection.Range.Text
     numarasiz = Mid(cumle, InStr(cumle, "."), Len(cumle))
     teklif = Mid(cumle, InStr(cumle, ".") + 1, 6)
     If teklif = "TEKLİF" Then
        say = say + 1
        sekil = Selection.Range.Style
        Selection.Range.Text = say & numarasiz
        Selection.Range.Style = sekil
        Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
        Selection.Font.Grow
        Selection.Font.Bold = wdToggle
     End If

     Selection.MoveDown Unit:=wdLine, Count:=1
     Selection.HomeKey Unit:=wdLine
 Wend

End Sub

 

[baysevimli]

Sn. Asri çok teşekkür ederim test ettim çalışıyor. Bir sorum olacak makro kodları üzerinde çalıştığım esas word dosyasına yapıştırsam orda da çalışır mı ? Ayrıca teklif ya da birden fazla teklif sildiğimde makro otomatik çalışabilir mi ? Bu mümkün değilse CTRL+ALT+M tuşlarına makroyu bağlayabilir miyiz ? Çok sağolun.

 

[Asri]

Word makrosu dosya bağımsız.
Yeni dosyaya yapıştırmanız yeterli olur.

Kısayol ve otomatik çalışma için bakmam gerekiyor. Müsait bir zamanda bakarım.

 

[baysevimli]

Kodları yeni sayfama yapıştırdığımda teklif kısımlarını 1 cm kadar içeri alıyor sola sıfır durmasını nasıl yapabiliriz ? Bide yeni sayfaya yapıştırdığımda karar no: alanları çalışmıyor.

 

[Asri]

Kodları yeni sayfama yapıştırdığımda teklif kısımlarını 1 cm kadar içeri alıyor sola sıfır durmasını nasıl yapabiliriz ? Bide yeni sayfaya yapıştırdığımda karar no: alanları çalışmıyor.

Sola sıfır durması sağlandı.
Yeni sayfada denendi sorun yok. Dosya yapısının verilen örnek dosyadaki gibi olması gerekiyor.

Karar no lar, [FONT=&quot]KARAR NO: [/FONT][FONT=&quot]olarak yazıl[FONT=&quot]malı,[/FONT] başında boşluk olmamalı ve bir table içinde olmadı. Elle table dışı yazılmış ile program bulamaz.[/FONT][FONT=&quot]

Kontrol ediniz.
[/FONT]
http://s2.dosya.tc/server/f8qman/Makro_Dosyasi.zip.html

 

[baysevimli]

Asri Bey Merhaba,

Son güncellediğiniz dosyayı denedim ama henüz istediğim sonucu alamadım o sebeple size üzerinde çalıştığım orijinal dosyayı gönderiyorum. Sizden istirhamım bu dosya üzerinde tekrar çalışıp gönderebilir misiniz ? İstediklerim tam olarak aşağıda bir daha özetledim.

1 – “.TEKLİF” olan yerlere en baştan başlayarak .TEKLİF’in başında sayı olsa da olmasa da “1”den başlayarak bir numara verecek.
2 – KARAR NO: alanında da ise ilk teklifin kararına hangi sayıyı yazarsam o sayıdan başlayıp birer birer arttıracak. Örneğin ilk karar sayım 100. Diğer tekliflerin karar nolarını 101,102 …. Diye sıralayacak.yeni örnek dosyam aşağıdaki linktedir. İlginiz çok teşekkür ederim.

http://s2.dosya.tc/server/zre80r/ORNEK_CALISMA.docx.html

 

[Asri]

Makroda bir sorun yok, örnek dosyada sayfa yapısını değiştirmişsiniz.

Bir önceki mesajımda belirtmiştim.
"Yeni sayfada denendi sorun yok. Dosya yapısının verilen örnek dosyadaki gibi olması gerekiyor."

Makronun çalışması için word deki ilk sayfayı silin.

Çalışma ile ilgili video ektedir.

http://s2.dosya.tc/server/q827qv/wordsatirekle.avi.html

 

[alicimri]

Sayın baysevimli biraz uğraştım işinize yararsa kullanın

Sub Makro1()
ActiveDocument.Select
ab = Split(Selection, ".TEKLİF")
say = UBound(ab)
 Selection.HomeKey Unit:=wdStory
    For i = 1 To say
Selection.Find.Text = ".TEKLİ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
Next
For i = 1 To ActiveDocument.Tables.Count
If Left(ActiveDocument.Tables(i).Cell(1, 1), 9) = "KARAR NO:" Then
ActiveDocument.Tables(i).Cell(1, 1).Range.Text = Left(ActiveDocument.Tables(i).Cell(1, 1), 9) & "0" & Left(Right(ActiveDocument.Tables(i).Cell(1, 1), 6), 5) + 1
End If
Next
End Sub