VBA Word - numerowanie tabel

Anonimowe

Mam problem z makro w Word. Może ktoś poprawi to makro, które nie działa w pełni tak jak powinno. Już tłumaczę o co chodzi.

W pliku Worda mam tabele podpisane jako "Tabela. [Nazwa tabeli]." Tabele nie są automatycznie numerowane, tak aby potem można było zrobić ich spis. Postanowiłem więc spróbować zrobić makro działające w taki sposób, aby:

Wszystkie akapity zaczynające się od "Tabela. zmieniały formatowanie stylu właściwego dla podpisu tabeli.
Słowa "Tabela. " zostały zastąpione na "Tabela [nr]. ", gdzie [nr] jest automatycznym, kolejnym numerem tabeli w dokumencie.

O ile udało mi się osiągnąć pkt. 1 to mam problem z pkt. 2 :(

Po zastosowaniu poniższego makro formatuje mi zgodnie ze stylem wszystkie akapity, które zaczynają się od "Tabela. ". Ale niestety tylko pierwsze występowanie słowa tabela jest numerowane na zasadzie "Tabela 1." a w pozostałych przypadkach makro usuwa słowa "Tabela. " i nie wstawia podpisu z automatycznym numerowaniem :( Nie potrafię niestety rozwiązać tego problemu. Będę bardzo wdzięczny za pomoc

Sub Change_Tabel()

Dim objDoc As Document

Dim head7 As Style

Set objDoc = ActiveDocument

Set head7 = ActiveDocument.Styles("Podpis nad obiektem")

With objDoc.Content.Find

.ClearFormatting

.Text = "Tabela. "

.MatchWildcards = True

With .Replacement

.ClearFormatting

.Style = head7

End With

.Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceAll

End With

With objDoc.Content.Find

.ClearFormatting

    Options.ReplaceSelection = True

ActiveDocument.Sentences(1).Select

.Execute FindText:="Tabela. "

.MatchWildcards = True

If .Found = True Then

Selection.Delete Unit:=wdCharacter, Count:=1

Selection.InsertCaption Label:=wdCaptionTable, TitleAutoText:="", \_

    Title:="", Position:=wdCaptionPositionAbove, ExcludeLabel:=0

Selection.TypeText Text:="." & vbTab

End If

.Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceAll

End With

End Sub

Pytanie zablokowane. To pytanie zostało zmigrowane ze społeczności pomocy technicznej firmy Microsoft. Możesz zagłosować, czy pytanie jest pomocne, ale nie możesz dodawać komentarzy ani odpowiedzi, ani też śledzić pytania.

Komentarze: 0

Odpowiedź zaakceptowana przez autora pytania

Oskar Shon 49,336 Moderator wolontariuszy

No, dobra :P

Sub Tabele_spis_ilustracji()
'MVP Oskar Shon www.VBATools.pl dodatki do Office
Dim p As Paragraph, i%, t$
Dim head7 As Style: Set head7 = ActiveDocument.Styles("Podpis nad obiektem")
For Each p In ActiveDocument.Paragraphs
    With p.Range
      t = Trim(.Text)
      If t Like "Tabela*" And Len(t) > 6 And Not t Like "Tabela #*" Then
         i = i + 1
         .Text = ""
         .Select
         Selection.InsertCaption Label:="Tabela", TitleAutoText:="InsertCaption1", _
            Title:=". " & Trim(Mid(t, 7)), Position:=0, ExcludeLabel:=0
         Selection.Style = head7
      End If
    End With
Next
End Sub

No i wyszło tak:

Pozdrawiam.

Komentarze: 0

Dodatkowe odpowiedzi: 17

Oskar Shon 49,336 Punkty reputacji Moderator wolontariuszy

2022-11-16T18:10:25+00:00
No dobra. Word jest w tym zakresie #$%^ i trzeba zakombinować bo faktycznie nie narysowałem sobie tabel pod słowami.

Teraz je mam i jest tak:

no to uruchamiam kod i mam tak:

Zatem wiedząc, że mają to być tabele to dodaje wiersz przed tabelą, a potem jak poprzednio.
```
Sub style_dla_tabela()
'MVP Oskar Shon www.VBATools.pl dodatki do Office
Dim rng As Range, tbl As Table
For Each tbl In ActiveDocument.Tables
       tbl.Select
       Set tbl = Selection.Tables(1)
       Set rng = tbl.Range
       rng.Collapse 1
       rng.Select
       Selection.SplitTable
       Set rng = tbl.Range
       rng.Collapse 0
       rng.InsertParagraphAfter
Next

Dim p As Paragraph, i%, t$
Dim head7 As Style: Set head7 = ActiveDocument.Styles("Podpis nad obiektem")
For Each p In ActiveDocument.Paragraphs
    With p.Range
      t = Trim(.Text)
      If t Like "Tabela*" And Len(t) > 6 And Not t Like "Tabela #*" Then
         'Debug.Print t
         i = i + 1
         .Text = "Tabela " & i & ". " & Trim(Mid(t, 7))
         .Style = head7
      End If
    End With
Next
End Sub
```
No i od razu mówię, że jeśli tekst jest zaraz nad tabelą to "wciągnie" do tabeli jest jakimś błędem Worda, który nie zostanie pewnie nigdy obsłużony, zatem musi się pojawić tam przerwa jaką wymuszam pierwszą pętlą po tabelach właśnie. Sprzątanie tych dodatkowych to pewnie 2h następnego siedzenia, które sobie już daruje.

Ta extra kropka, musi wynikać z twojego tekstu ale to już załatwia [Ctrl+h], bo ja dodaje tylko jedną (j.w.).

No i wisisz mi piwo.

Pozdrawiam.
Czy ta odpowiedź była pomocna?

Komentarze: 0 Brak komentarzy
Anonimowe

2022-11-16T17:23:24+00:00
Pojawiają się 2 błędy:
1. Nazwę tabeli wciąga do 1 wiersza tabeli.
2. Nazwa tabeli jest tworzona na zasadzie "Tabela NR. . ", a powinno być "Tabela NR. "
Poniżej screen:
Czy ta odpowiedź była pomocna?

Komentarze: 0 Brak komentarzy

Oskar Shon 49,336 Moderator wolontariuszy

Zrób sobie kopie pracy i spróbuj.

No taki efekt osiągnąłem z samych "Tabela aaa" "Tabela bbb" etc..

Sub style_dla_tabela()
'MVP Oskar Shon www.VBATools.pl dodatki do Office
Dim p As Paragraph, i%, t$
Dim head7 As Style: Set head7 = ActiveDocument.Styles("Podpis nad obiektem")
For Each p In ActiveDocument.Paragraphs
    With p.Range
      t = Trim(.Text)
      If t Like "Tabela*" And Len(t) > 6 And Not t Like "Tabela #*" Then
         'Debug.Print t
         i = i + 1
         .Text = "Tabela " & i & ". " & Trim(Mid(t, 7))
         .Style = head7
      End If
    End With
Next
End Sub

Pozdrawiam.

Komentarze: 0

Anonimowe

2022-11-16T16:24:39+00:00

Dokładnie tak :) szukamy zdań zaczynających się od "Tabela. "
Czy ta odpowiedź była pomocna?

Komentarze: 0 Brak komentarzy