Thema
|
Datum
|
Von Nutzer
|
Rating
|
Antwort
|
|
11.06.2020 14:47:05 |
Mike |
|
|
|
11.06.2020 17:00:41 |
ralf_b |
|
|
|
11.06.2020 18:42:21 |
Gast92555 |
|
|
|
11.06.2020 19:31:45 |
Gast5845 |
|
|
|
11.06.2020 20:37:26 |
Mike |
|
|
Bestehende Texte in Tabellen abfüllen |
15.06.2020 17:17:03 |
Mike |
|
|
Von:
Mike |
Datum:
15.06.2020 17:17:03 |
Views:
804 |
Rating:
|
Antwort:
|
Thema:
Bestehende Texte in Tabellen abfüllen |
Die Lösung sieht so aus:
Sub SlideNoteToTable()
'
' SlideNoteToTable Macro
' Formats the speaker text into a two-column table
'
' -----------------< Reduce all images proportionally by 50% >-----------------
Dim i As Long
With ActiveDocument
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
.ScaleHeight = 50
.ScaleWidth = 50
End With
Next i
End With
' -----------------< Change "Slide notes" and "Text Captions" to ---------
' ----------------- "Speaker text:" and "Screen text:" >-----------------
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="Slide notes", _
ReplaceWith:="Speaker text:", Replace:=wdReplaceAll
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="Text Captions", _
ReplaceWith:="Screen text:", Replace:=wdReplaceAll
' -----------------< Create Table >-----------------
Dim suchBereich As Range, TabBereich As Range, tabelle As Table
Dim collStart As Collection, collEnd As Collection
Dim d As Long
Set collStart = New Collection: Set collEnd = New Collection
'Startpunkte für die Tabellenbereiche sammeln (Speaker Text- Ende)
Set suchBereich = ActiveDocument.Range
With suchBereich.Find
.Text = "Speaker Text"
Do While .Execute
collStart.Add suchBereich.Paragraphs(1).Range.End + 1
Loop
End With
' Endpunkte für die Tabellenbereiche sammeln (Screen- Text Anfang)
Set suchBereich = ActiveDocument.Range
With suchBereich.Find
.Text = "Screen Text"
Do While .Execute
collEnd.Add suchBereich.Start - 1
Loop
End With
'Bereiche in Tabelle verwandeln
For d = collStart.Count To 1 Step -1
Set TabBereich = ActiveDocument.Range(collStart(d), collEnd(d))
Set tabelle = TabBereich.ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=2, AutoFitBehavior:=wdAutoFitWindow)
With tabelle
'hier alle Tabellenformatierungsoperationen
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPoints
.Borders.Enable = True
.Rows(1).HeadingFormat = True
.Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 2 / 3, RulerStyle:=wdAdjustProportional
End With
Next d
' -----------------< Delete empty tables >-----------------
Dim tabelleX As Table, zeile As Row
For Each tabelleX In ActiveDocument.Tables
For Each zeile In tabelleX.Rows
If Len(zeile.Range) = 4 Then 'dann ist nur eine leere Absatzmarke drin
zeile.Delete
End If
Next zeile
Next tabelleX
End Sub
|
- Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
- Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
- Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
- Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
- Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei
Antworten auf Ihren Beitrag zu benachrichtigen
Bitte geben Sie ein aussagekräftiges Thema an.
Bitte geben Sie eine gültige Email Adresse ein!
- Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
- Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
- Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
- Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
- Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei
Antworten auf Ihren Beitrag zu benachrichtigen
Thema
|
Datum
|
Von Nutzer
|
Rating
|
Antwort
|
|
11.06.2020 14:47:05 |
Mike |
|
|
|
11.06.2020 17:00:41 |
ralf_b |
|
|
|
11.06.2020 18:42:21 |
Gast92555 |
|
|
|
11.06.2020 19:31:45 |
Gast5845 |
|
|
|
11.06.2020 20:37:26 |
Mike |
|
|
Bestehende Texte in Tabellen abfüllen |
15.06.2020 17:17:03 |
Mike |
|
|