Dokument zerpflücken und einzeln speichern

06/09/2009 - 08:25 von Oliver | Report spam
Hallo zusammen,

ich habe nachfolgendes Makro einmal aufgezeichnet, damit klar wird, was ich
machen will.
Ich habe eine Word-Datei, in der die Rechnungen von Kunden alle
untereinander stehen. Nun soll jeweils eine Rechnung eines Kunden einzeln
abgespeichert werde.
Ich hatte mir das wie in dem Makro zu sehen so vorgestellt, dass jeweils am
Ende eines Kunden das Wort XXX_ENDE steht. Danach suche ich , lösche diesen
Kenner und markiere dann alles bis zum Dokumentanfang.
Das markierte wird ausgeschnitten und in ein neues Dokument eingefügt.
Dann soll aus der ersten Zeile die 9-stellige Kundennummer kopiert werden
und das neue Dokument unter dieser Kundennummer abgespeichert werden.
Jetzt wird das soeben gespeicherte Dokument geschlossen und aus der
Gesamtdatei wird durch 2x Zeile löschen eine Leerzeile und ein Seitenumbruch
gelöscht.

=> Dann für die nàchste Kundennummer.

Ich habe das mal für 5 Kundenrechnungen manuell gemacht - funktioniert für
mich zufriedenstellend.

=> nun müsste jedoch die Kundennummer wirklich kopiert und als Dateiname
übergeben werden und das Makro sollte endlos bis zum Ende der Datei laufen,
was aktuell nicht der Fall ist.

Ich bin für jede Hilfe dankbar, ich krieg das leider nicht alleine hin.

Vielen Dank



#######################################
Makro:

Attribute VB_Name = "NewMacros"
Sub Makro()
Attribute Makro.VB_Description = "Makro aufgezeichnet am 05.09.2009 von
ogross"
Attribute Makro.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.Makro"
'
' Makro Makro
' Makro aufgezeichnet am 05.09.2009 von ogross
'
Selection.Find.ClearFormatting
With Selection.Find
.Text = "XXX_ENDE"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Cut
Documents.Add DocumentType:=wdNewBlankDocument
Selection.PasteAndFormat (wdPasteDefault)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
ChangeFileOpenDirectory _
"C:\Dokumente und Einstellungen\ogross\Desktop\zerpflücken\"
ActiveDocument.SaveAs FileName:="111111111.doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
ActiveWindow.Close
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "XXX_ENDE"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Cut
Documents.Add DocumentType:=wdNewBlankDocument
Selection.PasteAndFormat (wdPasteDefault)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
Documents.Add DocumentType:=wdNewBlankDocument
ActiveWindow.Close
Selection.Copy
ChangeFileOpenDirectory _
"C:\Dokumente und Einstellungen\ogross\Desktop\zerpflücken\"
ActiveDocument.SaveAs FileName:="222222222.doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
ActiveWindow.Close
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "XXX_ENDE"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Cut
Documents.Add DocumentType:=wdNewBlankDocument
Selection.PasteAndFormat (wdPasteDefault)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
ChangeFileOpenDirectory _
"C:\Dokumente und Einstellungen\ogross\Desktop\zerpflücken\"
ActiveDocument.SaveAs FileName:="333333333.doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
ActiveWindow.Close
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "XXX_ENDE"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Cut
Documents.Add DocumentType:=wdNewBlankDocument
Selection.PasteAndFormat (wdPasteDefault)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
ChangeFileOpenDirectory _
"C:\Dokumente und Einstellungen\ogross\Desktop\zerpflücken\"
ActiveDocument.SaveAs FileName:="444444444.doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
ActiveWindow.Close
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Find.ClearFormatting
With Selection.Find
.Text = "XXX_ENDE"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.Cut
Documents.Add DocumentType:=wdNewBlankDocument
Selection.PasteAndFormat (wdPasteDefault)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
ChangeFileOpenDirectory _
"C:\Dokumente und Einstellungen\ogross\Desktop\zerpflücken\"
ActiveDocument.SaveAs FileName:="555555555.doc", FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="",
AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
ActiveWindow.Close
End Sub
 

Lesen sie die antworten

#1 Thomas Löwe [MS MVP Word]
06/09/2009 - 14:14 | Warnen spam
Hallo Oliver,

"Oliver" schrieb im Newsbeitrag
news:

ich habe nachfolgendes Makro einmal aufgezeichnet, damit klar
wird, was ich machen will.



du hast leider nicht die verwendete Version von Microsoft Word
angegeben. Bitte schließe diese Information bei allen weiteren
Anfragen ein.

Über eine VBA Lösung sollte dieses erreichbar sein.

Du solltest diese Frage auch mit den Experten in der Newsgruppe
news:microsoft.public.de.word.vba diskutieren.

Bei weiteren Fragen stehen wir dir jederzeit gern zur Verfügung.

Mit freundlichen Grüßen / With best regards
Thomas Löwe [Microsoft MVP Word]
Es erfolgt keine Beantwortung von Supportanfragen per E-Mail.
http://support.microsoft.com

Ähnliche fragen