PDA

Vollständige Version anzeigen : Office 2003 Makros


rih0815
14.08.2009, 10:42
Aufgabe:


Ich habe ein Dokument in office 2003 ca 900 Seiten ursprünglich als Serienbrief erstellt. Auf jeder Seite befindet sich immer gleiche Felder nur der Inhalt variiert in Textlänge und Text. Nun benötige ich ein Makro welches mir jede Seite einzeln unter einem neuen Namen abspeichert. Soweit so gut
Nun möchte ich anstatt des hochzählens des Formularnamens den Inhal einer
Zelle verwenden welche sich auf der jeweiligen Seite befindet.

Frage kann ich das über Koordinaten realisieren, da die Zelle ja keine Bezeichnung in MS Word hat.
Eventl. kann mir da jemand weiterhelfen.

Der Code fürs zählende speichern der einzelnen ist hier:


Sub Seitenspeichern()
Dim oPages, Counter
'
ActiveDocument.Repaginate
oPages = ActiveDocument. _
BuiltInDocumentProperties _
(wdPropertyPages)
'MsgBox oPages
Counter = 0
'
For i = 1 To oPages
Dim pRange As Range
Counter = Counter + 1
Selection.GoTo What:=wdGoToPage, _
Which:=wdGoToNext, Name:=CStr(i)
Set pRange = _
ActiveDocument.Bookmarks("\Page").Range
pRange.Select
pRange.Copy
'
DocName = ActiveDocument.Name & "-Seite" & Format(Counter)
Documents.Add
Selection.PasteAndFormat (wdPasteDefault)
'
ActiveDocument.SaveAs _
FileName:=DocName & ".doc", _
AddToRecentFiles:=False
ActiveDocument.Close
Next
'
Selection.Collapse
End Sub

Hotte
14.08.2009, 13:11
Hi,

Auf jeder Seite befindet sich immer gleiche Felder

Was sind das denn für Felder? Und wie stehen die denn im Originaldokument?
So weiß ich nicht, was Du meinst ...

Was meisnt Du mit "Zelle" - in einer Tabelle?

Also so ist die Hilfestellung eher etwas schwierig.

rih0815
17.08.2009, 06:02
So sieht eine Seite aus (Ausschnitt)

Es handelt sich um eine Zelle in einer Tabelle, diese sich ändernde Nummer soll für den Name der gepeicherten Seite verwendet werden.

rih0815
17.08.2009, 17:26
Sollte die Fragestellung undurchsichtig sein bitte ich sie mir das mitzuteilen.
Ansonsten hoffe ich schon auf eine Antwort..

Hotte
17.08.2009, 19:48
Hi,

ja - es ist noch undurchsichtig. Und ja - ich mach das in meiner Freizeit.... daher kann es mal ein wenig dauern....

In der Tabellenzelle ist ein Seriendruckfeld? Wird also aus der Sereindruckquelle gefüllt?

Und hast Du nun alles bereits in eine Datei "gedruckt" - sodass Du für jeden Datensatz in der Quelle eine Seite hast?

rih0815
18.08.2009, 06:23
Der Serienbrief ist fertig (gedruckt), dass würde aber heißen die Hintergrundinformationen ob dieses Feld ein Seriendruckfeld war sind doch schon verloren gegangen, oder?
Auf jeden Fall sind sie an der gleichen Position, und ja ich habe für jeden Datensatz eine Seite in diesem Dokument.

Ich bin wohl etwas ungeduldig hehe

Hotte
18.08.2009, 09:36
Hi,

so kann man es sagen. Aber ich muss das mal testen, wie man es hinbekommt.

Wird aber eher morgen abend werden, da ich heute keine Zeit mehr habe.

rih0815
22.08.2009, 14:23
Hat eventl. doch noch jemand eine Idee zu diesem Thema?

Hotte
22.08.2009, 17:32
Hi,

ja ich. Aber Du musst es erstmal testen. Denn ich kenne die Tabelle nicht. Vom Bild kann man es erstmal nur vermuten.

Hier mal der Code ... der Serienbrief ist bereits in einer Datei zusammengeführt.


Sub Seriendruck_trennen()
Dim oDoc As Document, Abschnitt As Section, nDoc As Document
Dim Verzeichnis As String, i As Long, DateiName As String

Set oDoc = ActiveDocument
'hier den Pfad für den neuen Speicherort festlegen
Verzeichnis = oDoc.Path
If Right(Verzeichnis, 1) <> Application.PathSeparator Then Verzeichnis = Verzeichnis & Application.PathSeparator

For i = 1 To oDoc.Sections.Count
Set Abschnitt = oDoc.Sections(i)
Set nDoc = Documents.Add(oDoc.AttachedTemplate.FullName)
nDoc.Content.FormattedText = Abschnitt.Range.FormattedText
nDoc.Range.Find.Execute FindText:="^b", ReplaceWith:="" 'Abschnittwechsel suchen und löschen
DateiName = Verzeichnis & Left(oDoc.Name, Len(oDoc.Name) - 4) & "_" & Zellwert(nDoc.Tables(1).Cell(3, 2).Range) & ".doc"
nDoc.SaveAs FileName:=DateiName, AddToRecentFiles:=False
nDoc.Close
Next i

End Sub

Function Zellwert(Zellinhalt As String) As String

'Zeichen: Chr(13) = Absatzmarke - gehört auch zum Zeichen Zellenende
' Chr(11) = bedingter Absatz
' Chr(7) = eigentlich undefiniert - gehört zum Zeichen Zellenende
' Chr(160)= Steuerzeichen Absatz (eigentlich frei - kann aber vorkommen)
' Chr(10) = Absatzmarke
' Chr(32) = Leerzeichen
' Chr(9) = Tabulator

Dim strWert As String

strWert = Zellinhalt
Do While InStr(1, strWert, Chr(13)) <> 0 Or InStr(1, strWert, Chr(7)) <> 0 Or InStr(1, strWert, Chr(160)) <> 0 _
Or InStr(1, strWert, Chr(10)) <> 0 Or InStr(1, strWert, Chr(11)) <> 0 Or InStr(1, strWert, Chr(32)) <> 0 _
Or InStr(1, strWert, Chr(9)) <> 0
strWert = Left(strWert, Len(strWert) - 1)
Loop

Zellwert = strWert

End Function



Der Dateiname der einzelnen Dokuemnte wird zusammengesetzt aus dem Namen des Serienbriefes und dem Zellinhalt (also der Nummer), getrentn durch einen Unterstrich. Das kansnt Du natürlich ändern.

Die Dateien werden dort gespeichert, wo der Serienbrief auch gespeichert ist.

rih0815
24.08.2009, 06:31
Danke für den Code!!

Ich habe mal ein Testfile upgeloaded.

Bei mir bleibt er in der ersten Seite hängen


Das *.txt bitte in *.zip ändern und entpacken

Hotte
24.08.2009, 06:36
Hi,

was heißt, "er bleibt hängen"? Welche Fehlermeldung gibt es bzw. wie sieht die 1. Seite denn aus?

Lade die zip-Datei hoch ... die txt-Datei ist kein gültiges Archiv.

rih0815
24.08.2009, 06:40
Die testfile.txt in testfile.zipx umbenennen oder testfile.zip unbenennen.
Ich kann die Doc nicht hochladen, da sie zu groß ist und zips dürfen nicht hochgeladen werden :grins:


Laufzeitfehler '5941'

Das angeforderte Elemente ist nicht in der Sammlung vorhanden

Laufzeitfehler in der Zeile für den DateiNamen, welchen er nicht bilden kann

Hotte
24.08.2009, 06:57
Hi,

selbstverständlich können zip-Dateien hochgeladen werden. Aber auch nur solche.

Die obige Datei wird nicht als Archiv erkannt und kann nicht entpackt werden. Womit hast Du es denn gepackt?

rih0815
24.08.2009, 07:23
Mit WinZip 12.1

Hotte
24.08.2009, 07:26
Du hast eine PN ...

Der Winrar hat es ncith alks Archiv erkannt. Da scheint was nicht zu stimmen....

rih0815
24.08.2009, 07:27
Das File nochma mit der alten Zip methode

rih0815
24.08.2009, 12:33
Das Mail ist unterwegs....

PS:
Ich hatte doch einen 2ten Post geschickt mit einem abwärtskompatiblen Zip als Anhang :boah: aber wo ist es hin.

Hotte
24.08.2009, 13:46
Hi,

so - ist alels angekommen uns getestet.

Der Fehler war bei dem letzten Abschnitt. Daher hier mal der Code, der auf jeden Fal lfunktioniert. Übrigens hatte er ja bis zum Fehler alle Teildokumente erstellt.

Teste mal diesen Code bei Dir:

Sub Seriendruck_trennen()
Dim oDoc As Document, Abschnitt As Section, nDoc As Document
Dim Verzeichnis As String, i As Long, DateiName As String

Set oDoc = ActiveDocument
'hier den Pfad für den neuen Speicherort festlegen
Verzeichnis = oDoc.Path
If Right(Verzeichnis, 1) <> Application.PathSeparator Then Verzeichnis = Verzeichnis & Application.PathSeparator
On Error GoTo Ende
For i = 1 To oDoc.Sections.Count
Set Abschnitt = oDoc.Sections(i)
Set nDoc = Documents.Add(oDoc.AttachedTemplate.FullName)
nDoc.Content.FormattedText = Abschnitt.Range.FormattedText
nDoc.Range.Find.Execute FindText:="^b", ReplaceWith:="" 'Abschnittwechsel suchen und löschen
DateiName = Verzeichnis & Left(oDoc.Name, Len(oDoc.Name) - 4) & "_" & Zellwert(nDoc.Tables(1).Cell(3, 2).Range) & ".doc"
nDoc.SaveAs FileName:=DateiName, AddToRecentFiles:=False
nDoc.Close
Next i
Exit Sub
Ende:
nDoc.Close False

End Sub


Der sollte funktionieren....

rih0815
24.08.2009, 16:48
ehm... tut mir Leid, aber bei mir kommt

Fehler beim Kompilieren:

Sub oder Function nicht definiert

Depugged bei Zellwert


Eventl eine blöde Frage, aber gibt es irgendwo Listen mit diesen Makro befehlen mit Beispielen?

rih0815
24.08.2009, 17:28
Also der Code funzt jetzt....

Sub Seriendruck_trennen()
Dim oDoc As Document, Abschnitt As Section, nDoc As Document
Dim Verzeichnis As String, i As Long, DateiName As String

Set oDoc = ActiveDocument
'hier den Pfad für den neuen Speicherort festlegen
Verzeichnis = oDoc.Path
If Right(Verzeichnis, 1) <> Application.PathSeparator Then Verzeichnis = Verzeichnis & Application.PathSeparator
On Error GoTo Ende
For i = 1 To oDoc.Sections.Count
Set Abschnitt = oDoc.Sections(i)
Set nDoc = Documents.Add(oDoc.AttachedTemplate.FullName)
nDoc.Content.FormattedText = Abschnitt.Range.FormattedText
nDoc.Range.Find.Execute FindText:="^b", ReplaceWith:="" 'Abschnittwechsel suchen und löschen
DateiName = Verzeichnis & Left(oDoc.Name, Len(oDoc.Name) - 4) & "_" & Zellwert(nDoc.Tables(1).Cell(3, 2).Range) & ".doc"
nDoc.SaveAs FileName:=DateiName, AddToRecentFiles:=False
nDoc.Close
Next i
Exit Sub
Ende:
nDoc.Close False

End Sub

Function Zellwert(Zellinhalt As String) As String

'Zeichen: Chr(13) = Absatzmarke - gehört auch zum Zeichen Zellenende
' Chr(11) = bedingter Absatz
' Chr(7) = eigentlich undefiniert - gehört zum Zeichen Zellenende
' Chr(160)= Steuerzeichen Absatz (eigentlich frei - kann aber vorkommen)
' Chr(10) = Absatzmarke
' Chr(32) = Leerzeichen
' Chr(9) = Tabulator

Dim strWert As String

strWert = Zellinhalt
Do While InStr(1, strWert, Chr(13)) <> 0 Or InStr(1, strWert, Chr(7)) <> 0 Or InStr(1, strWert, Chr(160)) <> 0 _
Or InStr(1, strWert, Chr(10)) <> 0 Or InStr(1, strWert, Chr(11)) <> 0 Or InStr(1, strWert, Chr(32)) <> 0 _
Or InStr(1, strWert, Chr(9)) <> 0
strWert = Left(strWert, Len(strWert) - 1)
Loop

Zellwert = strWert

End Function



Danke, aber die Zellen werde in den neuen einzelnen Files anders formatiert. Ka was daran schuld ist :top: :top: :top: :top: :top:

Hotte
24.08.2009, 18:24
Hi,

ja - der Teil des Codes (Function Zellwert) bleibt ja unverändert...

Das konnte ich nicht so testen - kenne die Formatierungen ja nicht. Eigentlich sollte es soweit formatiert übertragen werden.:rolleyes:

rih0815
26.08.2009, 06:56
Die Formatierung des Serienbriefes passt nicht mit den (Seite einrichten) Eigenschaften der einzelnen Blätter, welche mit dem Makro aus dem Serienbrief erzeugt werden zusammen.

Gibt es eine Möglichkeit die (Seite einrichten) Eigenschaften der einzelnen Blätter vorzugeben? Siehe Grafik…

rih0815
26.08.2009, 07:21
Also das mit der Formatierung hat sich erledigt, ich habe einfach
bei Seite einrichten meine Werte als Standart definiert und funzt.

Schaffe ich es nun irgendwie den Namen der Files so zu ändern, das wie im
Testfile testa_testb rauskommt?

rih0815
27.08.2009, 15:25
Das mit Filename testa1_testb1 habe ich auch selbst hinbekommen *freu*freu*

Einfach nur auf diesen Code geändert.

DateiName = Verzeichnis & Zellwert(nDoc.Tables(1).Cell(3, 2).Range) & "_" & Zellwert(nDoc.Tables(1).Cell(3, 4).Range) & ".doc"

Ich danke Hotte nochmal für diese großartige Arbeit ;)