Office: Überschriften in Word auslesen (VBA)

Hallo erstmal,

mein Problem ist das ich verschiedene Überschriften (Überschrift1, Überschrift2, Überschrift in Tabelle) aus einem word-Dokument auslesen muss. Danach soll ich für jede Überschrift1 ein neues Dokument mit der Überschrift als Dokumenten-Name erstellen und die untergeordneten Überschrift2 soll dann in das neue Dokument der jeweilige Überschrift1 hinzugefügt werden.

Ich weiß das klingt verwirrend aber für mich als VBA-Neuling ist das ein Loch ohne Boden.

Kann mir jemand bei diesem Problem helfen oder wenigstens ein paar Tips geben? Ich bin über jede Form von Hilfe dankbar.

MfG

:)

 

Hallo,

hab zwar keine fertige Lösung, aber einen Ansatz:

Folgendes Makro kopiert Dir alle Kaptile (zwischen den Überschriften der Ebene 1) in neue Dokumente.

Sub Temp()
Dim rng As Range, rngÜ As Range
Dim oDoc As Document, tmpDoc As Document
Set oDoc = ActiveDocument
Set rng = oDoc.Range
With rng.Find
.Text = ""
.Style = wdStyleHeading1
.Forward = True
.Execute
Do While .Found = True
rng.Select
' Kapitel markieren und merken
Set rngÜ = Selection.Bookmarks("\HeadingLevel").Range
' neues Dok erstellen
Set tmpDoc = Documents.Add
' Kapitelinhalt rüberkopieren
tmpDoc.Range.InsertAfter rngÜ.Text
' nächstes Kapitel suchen
.Execute
Loop
End With
End Sub

HTH
Christian

 

Wow, das bringt mich schon mal weiter. Dank dir!
Wie kann ich es realisieren das die Dokumente in dem gleichen Pfad gespeichert werden wie das Ursprungsdokument? Hab da einen konstanten Verzeichnispfad. Oder wie kann man das trennen das nich die gesamten Kapitel sondern nur die Überschrift2 übertragen werden?

 

indem Du den Pfad des Originaldoks verwendest:

oDoc.Path

diesen verwendest Du dann beim Speichern der neuen Dokumente

tmpDoc.SaveAs FileName:=oDoc.Path & "\" & strDateiName

Möchtest Du jeweils nur die Überschriftend er Ebene 2 rauskopieren, sollte die Änderung

.Style = wdStyleHeading2 '!

 

An welcher Stelle der While Schleife muss das mit dem speichern hin? Kann man die übertragenden Texte wieder formatieren?

 

Hallo,

das kommt direkt nach dem Rüber-kopieren:

Sub Temp()
Dim rng As Range, rngÜ As Range
Dim rngNewDoc As Range
Dim oDoc As Document, tmpDoc As Document
Set oDoc = ActiveDocument
Set rng = oDoc.Range
With rng.Find
.Text = ""
.Style = wdStyleHeading2
.Forward = True
.Execute
Do While .Found = True
rng.Select
' Kapitel markieren und merken
Set rngÜ = Selection.Bookmarks("\HeadingLevel").Range
' neues Dok erstellen
Set tmpDoc = Documents.Add
' Kapitelinhalt rüberkopieren
tmpDoc.Range.InsertAfter (rngÜ.Text)
Set rngNewDoc = tmpDoc.Range
'Hier folgenden die Formatierungen
With rngNewDoc
.Font.Bold = True
End With
' Speichern Dialog mit Dateinamen-Vorschlag aus Ü2
With Dialogs(wdDialogFileSaveAs)
.Name = oDoc.Path & "\" & Left(rngÜ.Paragraphs(1).Range.Text, _
Len(rngÜ.Paragraphs(1).Range.Text) - 1)
.Show
End With
' nächstes Kapitel suchen
.Execute
Loop
End With
End Sub

mit dieser Erweiterung wird zum Einen der eingefügte Text im Range rngNewDoc gemerkt und kann formatiert werden, und zum Anderen wird zum Speichern der Ü2-Text als Dateinamen-Vorschlag angeboten.

HTH
Christian

 

Als Dateinamen brauche ich Überschrift1, aber das is ja jetzt klar. Soweit so gut... wie formatiere ich den übertragenden Überschriften und Texte? Ist es möglich das die Formatierungen von Überschrift2 und Überschrift3 in Tabelle in das neue Doc übernommen werden?

 

Könntest Du mir diesen Satz

mal genauer erklären?
Kapier ihn nicht (wirklich) *confused.gif*

Christian

 

In dem Quelldokument gibt es verschiedene Überschriften. Zum einen Überschrift1 --> daraus soll eine neues Dokument entstehen. Dann gibt es Überschrift2 die in das jeweilige Dokument übernommen werden soll (am besten mit Nummerierung). Und dann gibt es noch Tabellen in denen die erste Spalte eine "Überschrift3 in Tabellen" enthält. Die Formatierung nennt sich so. Diese sollen auch in das jeweilige neue Dokument übernommen werden. Verstehst du jetzt was ich meine?
Ich habe selbst Probleme das ganze zu erfassen da es ziemlich komplex ist.

MfG

 

Hallo,

achso.
Das läuft in VBA unter dem Begriff "OrganizerCopy"

Ich seh da im Augenblick zwei Möglichkeiten:
a)
alle Formatvorlage rüberkopieren:
Sub test()
Dim oDoc As Document, nDoc As Document
Set oDoc = ActiveDocument
Set tmpDoc = Documents.Add
tmpDoc.CopyStylesFromTemplate oDoc.AttachedTemplate
tmpDoc.Paragraphs(1).Style = "blabla"
End Sub

b) gezielt nur eine Vorlage

Sub test2()
Dim oDoc As Document, tmpDoc As Document
Set oDoc = ActiveDocument
Set tmpDoc = Documents.Add
Application.OrganizerCopy oDoc.Name, tmpDoc.Name, "blabla", wdOrganizerObjectStyles
End Sub


schau mal, ob Du damit weiterkommst...

Gruß
Christian

 

Mhh steig da jetzt nicht ganz durch wie ich das wieder in das vorhergehende integrieren kann. Oh man von VBA hab ich keine Ahnung. Hoffe du verstehst das...

Wo muss das rein?

 

Hi,

najut, mach ich Dir dann fertig.
Allerdings sitze ich erst morgen wieder am Testrechner, nun ist Computer-Feierabend *angel

Brauchst Du dann nur die eine Vorlage von Überschrift3-in-Tabelle oder sicherheitshalber auch die der anderen Überschriften, Textstandards etc.?

Hastalavista
Christian

 

Nö ich brauche nur Überschrift3 in Tabellen und vllt. allerhöhsten Überschrift4 in Tabellen. Oh man bist mir ne echt große Hilfe dank dir schon mal im vorraus!!!

 

Hi,

ok, teste mal, ob das alles berücksichtigt.
Nun werden auch Formatierungen und Tabellen sauber kopiert.

Sub Temp()
Dim rng As Range, rngÜ As Range
Dim rngNewDoc As Range
Dim oDoc As Document, tmpDoc As Document
Set oDoc = ActiveDocument
Set rng = oDoc.Range
With rng.Find
.Text = ""
.Style = wdStyleHeading2
.Forward = True
.Execute
Do While .Found = True
rng.Select
' Kapitel markieren und merken
Set rngÜ = Selection.Bookmarks("\HeadingLevel").Range
rngÜ.Copy
' neues Dok erstellen
Set tmpDoc = Documents.Add
' Kapitelinhalt rüberkopieren
tmpDoc.Content.PasteSpecial
tmpDoc.Range.Collapse wdCollapseEnd
Set rngNewDoc = tmpDoc.Range
'Hier folgenden die Formatübertragungen
With tmpDoc
Application.OrganizerCopy oDoc.Name, .Name, "Überschrift3 in Tabellen", wdOrganizerObjectStyles
Application.OrganizerCopy oDoc.Name, .Name, "Überschrift4 in Tabellen ", wdOrganizerObjectStyles
End With
' Speichern Dialog mit Dateinamen-Vorschlag aus Ü2
With Dialogs(wdDialogFileSaveAs)
.Name = oDoc.Path & "\" & Left(rngÜ.Paragraphs(1).Range.Text, _
Len(rngÜ.Paragraphs(1).Range.Text) - 1)
.Show
'End With
' nächstes Kapitel suchen
.Execute
Loop
End With

HTH
Christian

 

Hallo,

sag mal kannst du mir bitte mal erklären was diese Zeilen-Code machen:

With tmpDoc
Application.OrganizerCopy oDoc.Name, .Name, "Überschrift3 in Tabellen", wdOrganizerObjectStyles
Application.OrganizerCopy oDoc.Name, .Name, "Überschrift4 in Tabellen ", wdOrganizerObjectStyles
End With

Ich steig da nicht ganz durch. Bei mir schreibt er nichts in die neuen Dokumente rein. Man erkennt nur das es kursive Schrift sein soll.

Ist es möglich die Speicherung der neuen Dokumente mit dieser Funktion bei deinem Code einzubinden?

Private Function CreateNewDoc(strName As String) As Document
Const KONZEPT_DOT = "D:\MyProjects\VBA" ' voller Pfad zur Vorlage
Dim strNewPath As String
Dim strNewName As String

On Error Resume Next
Set CreateNewDoc = Documents.Add(KONZEPT_DOT)
' Verz. kann natürlich auch in Steuerung angelegt werden
strNewPath = objDoc.Path & Application.PathSeparator & "Konzept"

If Dir(strNewPath, vbDirectory) = "" Then
MkDir strNewPath ' Zuweisung als Pfad-Variable
strNewName = strName
' jetzt müssen noch die ganzen Validierungen erfolgen (z.B. u.a. mit replace(), wenn verfügbar)
' es ist die Frage, wie reagiert werden soll, wenn's trotzdem einen Fehler gibt - hier also mal geht's nicht weiter
CreateNewDoc.SaveAs strNewPath & Application.PathSeparator & strNewName & ".doc" ' ggf. weitere Argumente
If Err.Number 0 Then
Debug.Print Err.Number, Err.Description
Set CreateNewDoc = Nothing
End If
End If
End Function