BONUS WORD 97 Makro: Wort-Dubletten beseitigen (ALT)

Autor:
Jrgen Hinrichs
schul16@gmx.net
http://mitglied.lycos.de/erleuchtet/index-g.htm
Infos und Tips fr Word, Windows, Access, Excel, Internet

Dieses Makro unterliegt dem Urheberrecht und bleibt Eigentum des Autors.
Es ist Freeware und darf unter Nennung des Autors und der Herkunft
unentgeltlich weitergegeben werden.

Es darf weder verkauft noch verliehen noch anderweitig kommerziell
vertrieben werden, auch nicht in genderter oder erweiterter Form.

Jedwede Haftung wird ausgeschlossen.
Weitere Makros auf Anfrage.


###############

Makros Listen Bereinigen / Tabellen Bereinigen ALT

"Dubletten3"
Listen Bereinigen

Das Makro ordnet zusammengefgte, redundante Wortlisten aus Wrterbchern etc. und beseitigt Dubletten, auch kurze Stze. Auch aus Texten.	Fr Tabellen ist das Makro 


"Dubletten4"
Tabellen Bereinigen

zustndig. 

Das Makro ordnet zusammengefgte, redundante Tabellen und beseitigt Dubletten. Jetzt auch mit kurzen Stzen, Tabelle wird allerdings zur Liste! 
 
Das Makro ist unausgereift und mu ggf. mehrfach ausgefhrt werden. 

Alles geschieht auf eigene Gefahr. Behandelte Dateien werden unwiderruflich verndert. Es gibt keine Garantie auf Datenintegritt. 

Wichtige Dateien deshalb grundstzlich bitte vorher sichern, am besten mehrfach. 

Es darf sich im Dokument jeweils nur eine Wortliste oder eine Tabelle befinden.

Die behandelte Liste mu, wenn gewnscht, manuell durch Tabellen - Text in Tabelle unter Angabe des Trennzeichens: Tabstops und Kontrolle der Spaltenzahl zurck in eine Tabelle verwandelt werden. Eine Automatik wre an dieser Stelle fehleranfllig. Ggf. vorher Bearbeiten - Alles Markieren.


Mit dem Makro "Dubletten4" (Alte Version) wird nur die erste Spalte einer Tabelle geprft und gelscht; der Zusammenhang bleibt erhalten. Aber nur jeweils  ein Wort! Zweimal ausgefhrt, sortiert es die Dubletten an den Anfang. hnliches gilt fr "Dubletten3".


###############


Den unten stehenden Makro- Code kopieren und in MS WORD 97
ber

 "Extras / Makro / Makros: Erstellen"

unter einem ausgewhlten Namen vollstndig in das sich ffnende Editor- Fenster einfgen.


Erstes Makro: 


CODE AB HIER KOPIEREN (inklusive der Anfangs- und Endzeilen mit "Sub / End Function") 

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Sub Dubletten3()
Rem Makro erstellt 1999 von Juergen Hinrichs schul16@gmx.net


Rem sortiert Listen und beseitigt Dubletten


WordBasic.StartOfDocument
WordBasic.InsertPara
WordBasic.StartOfDocument

WordBasic.WW7_EditGoTo Destination:="t"
If WordBasic.SelInfo(13) = -1 Then GoTo Weiter Else GoTo Halt

Halt:
WordBasic.MsgBox "Falsches Makro. ."
WordBasic.MsgBox "Im Dokument befindet sich eine Tabelle"
Exit Sub

Weiter:
WordBasic.TableSort DontSortHdr:=0, FieldNum:="Abstze", Type:=0, Order:=0, FieldNum2:="", Type2:=0, Order2:=0, FieldNum3:="", Type3:=0, Order3:=0, Separator:=0, SortColumn:=0, CaseSensitive:=1

WordBasic.StartOfDocument

WordBasic.EditReplace Find:="^a^a^a^a^a^a", Replace:="^a", Direction:=0, MatchCase:=0, WholeWord:=0, PatternMatch:=0, ReplaceAll:=1, Format:=0, Wrap:=0

WordBasic.EditReplace Find:="^a^a^a^a^a", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^a^a^a^a", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^a^a^a", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^a^a", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0

WordBasic.EditReplace Find:="^a  ", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^a ", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:=" ^a ", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0

WordBasic.EditReplace Find:="^a^a", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^a^a", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^a^a", Replace:="^a", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0


Rem ENDE VORBEREITUNG

Start:

Rem NUR BIS DOKUMENT ENDE Vorgehen
While WordBasic.CmpBookmarks("\Sel", "\EndOfDoc")


Rem MARKIEREN UND MERKEN

Rem BeginnZeile


WordBasic.EditFind Find:="^a", Direction:=1, MatchCase:=1, WholeWord:=0, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0
WordBasic.ParaDown
WordBasic.WordRight 1, 1


WordBasic.EditFind Find:=WordBasic.[Selection$](), Direction:=0, MatchCase:=1, WholeWord:=1, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0

Rem Textflu=0 hier unbedingt! Sonst geht IF nicht bei BeginnZeile!!

Rem PRFT OB DIE MARKIERUNG GRSSER IST ALS 0 - HIER SINNLOS
Rem     If MarkPrf = 0 Then MsgBox "Keine Markierung vorhanden."

Rem ENDE PRFUNG

Rem BEDINGUNG PRFEN

If WordBasic.EditFindFound() <> 0 Then

Rem LSCHANWEISUNG, SPEZIFISCH
WordBasic.WW6_EditClear

WordBasic.ParaUp 2

WordBasic.EditReplace Find:="^a^a", Replace:="^a", Direction:=0, ReplaceOne:=1, Format:=0, Wrap:=0

WordBasic.ParaUp



Rem WAS SONST; SPEZIFISCH; BEI LISTE ABSATZ
Else
WordBasic.ParaDown
End If

GoTo Start




Rem GEHRT ZU DOKUMENTENDE
Wend

WordBasic.StartOfDocument
WordBasic.EditReplace Find:="^a", Replace:="", Direction:=0, ReplaceOne:=1, Format:=0, Wrap:=0



End Sub


Rem-----------------

Rem UNTERMAKRO

Private Function MarkPrf()
    If WordBasic.GetSelStartPos() = _
            WordBasic.GetSelEndPos() Then
        MarkPrf = 0
    Else
        MarkPrf = 1
    End If
End Function



+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Zweites Makro:  


CODE AB HIER KOPIEREN (inklusive der Anfangs- und Endzeilen mit "Sub / End Function") 

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Sub Dubletten4()
Rem Makro erstellt 1999 von Juergen Hinrichs schul16@gmx.net


Rem sortiert Tabellen und beseitigt Dubletten

WordBasic.StartOfDocument
Rem EinfgenAbsatz
Rem BeginnDokument

WordBasic.WW7_EditGoTo Destination:="t1"

If WordBasic.SelInfo(13) = -1 Then GoTo Halt Else GoTo Weiter

Halt:
WordBasic.MsgBox "Falsches Makro. ."
WordBasic.MsgBox "Im Dokument befindet sich keine Tabelle"
Exit Sub

Weiter:
WordBasic.TableSelectTable

WordBasic.TableSort DontSortHdr:=0, FieldNum:="Spalte1", Type:=0, Order:=0, FieldNum2:="", Type2:=0, Order2:=0, FieldNum3:="", Type3:=0, Order3:=0, Separator:=0, SortColumn:=0, CaseSensitive:=1

WordBasic.ToolsOptionsView DraftFont:=0, WrapToWindow:=0, PicturePlaceHolders:=0, FieldCodes:=0, Bookmarks:=0, FieldShading:=2, StatusBar:=1, HScroll:=1, VScroll:=1, StyleAreaWidth:="0 cm", Tabs:=1, Spaces:=1, Paras:=1, Hyphens:=0, Hidden:=0, ShowAll:=0, Drawings:=0, Anchors:=0, TextBoundaries:=0, VRuler:=0

WordBasic.StartOfLine

WordBasic.TableSelectTable
WordBasic.FormatFont Hidden:=1

WordBasic.StartOfLine

WordBasic.TableSelectColumn
WordBasic.FormatFont Hidden:=0

Rem TabelleTabelleMarkieren
Rem TabelleInText .UmwandelnIn = 1

WordBasic.StartOfDocument

WordBasic.EditReplace Find:="^a^a", Replace:="", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^a^a", Replace:="", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0
WordBasic.EditReplace Find:="^a^a", Replace:="", Direction:=0, ReplaceAll:=1, Format:=0, Wrap:=0

Rem ENDE VORBEREITUNG

Start:

Rem NUR BIS DOKUMENT ENDE Vorgehen
While WordBasic.CmpBookmarks("\Sel", "\EndOfDoc")

Rem MARKIEREN UND MERKEN

Rem BeginnZeile

Rem BearbeitenSuchen .Suchen = "^a", .Richtung = 1, .GroKleinschreibung = 1, .GanzesWort = 0, .Mustervergleich = 0, .Reserviert23 = 0, .Format = 0, .Textflu = 0
Rem AbsatzUnten

WordBasic.StartOfLine
Rem ZeileUnten 1
Rem BeginnZeile

WordBasic.WordRight 1, 1

Rem PRFT OB DIE MARKIERUNG GRSSER IST ALS 0 - HIER SINNLOS
Rem     If MarkPrf = 0 Then MsgBox "Keine Markierung vorhanden."

On Error Resume Next

WordBasic.EditFind Find:=WordBasic.[Selection$](), Direction:=0, MatchCase:=1, WholeWord:=1, PatternMatch:=0, SoundsLike:=0, Format:=0, Wrap:=0

Rem Unbedingt zusammenlassen, Markierung ist nicht gleich Zwischenablage!
Rem Textflu=0 hier unbedingt! Sonst geht IF nicht bei BeginnZeile!!

Rem ENDE PRFUNG

Rem BEDINGUNG PRFEN

If WordBasic.EditFindFound() <> 0 Then

Rem LSCHANWEISUNG, SPEZIFISCH
WordBasic.WW6_EditClear

WordBasic.StartOfLine
WordBasic.LineUp 1
WordBasic.StartOfLine

Rem WAS SONST; SPEZIFISCH; BEI LISTE ABSATZ
Else
WordBasic.StartOfLine
WordBasic.LineDown 1
WordBasic.StartOfLine

End If

GoTo Start

Rem GEHRT ZU DOKUMENTENDE
Wend

WordBasic.StartOfDocument
WordBasic.EditReplace Find:="^a", Replace:="", Direction:=0, ReplaceOne:=1, Format:=0, Wrap:=0

WordBasic.StartOfDocument
WordBasic.LineDown
WordBasic.TableSelectTable
WordBasic.FormatFont Hidden:=0

WordBasic.ToolsOptionsView DraftFont:=0, WrapToWindow:=0, PicturePlaceHolders:=0, FieldCodes:=0, Bookmarks:=0, FieldShading:=2, StatusBar:=1, HScroll:=1, VScroll:=1, StyleAreaWidth:="0 cm", Tabs:=0, Spaces:=0, Paras:=0, Hyphens:=0, Hidden:=0, ShowAll:=0, Drawings:=0, Anchors:=0, TextBoundaries:=0, VRuler:=0

End Sub

Rem-----------------

Rem UNTERMAKRO

Private Function MarkPrf()
    If WordBasic.GetSelStartPos() = _
            WordBasic.GetSelEndPos() Then
        MarkPrf = 0
    Else
        MarkPrf = 1
    End If
End Function



+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++





Neue Makros in MS WORD 97 integrieren:

 "Extras / Anpassen / Befehle / Kategorien: Makros"

Makro auswhlen und durch Ziehen mit der Maus in ein Men einfgen oder ber "Tastatur" mit einer Tastenkombination belegen, 



Alternativ das Makro direkt ber

 "Extras / Makro / Ausfhren" 	

auswhlen und ausfhren lassen.




Einbau und Betrieb des Makros geschieht auf eigenes Risiko.

(c) 1999 Jrgen Hinrichs




