title image


Smiley Neue Version


Neue Version



' Verlangt Microsoft Forms 2.0 Object library

' Extras | Verweise



Zu Deinen Punkten:



1.

OK



2.

OK



3.

siehe 2.





Viele Grüße!



C.











Option Explicit



' Doppelte Eintraege Der Ersten Spalte Der Ersten Tabelle Rot Markieren

' Jedes mehrfache Vorkommen wird rot markiert (nicht nur ab dem zweiten)

    

' Verlangt Microsoft Forms 2.0 Object library

' Extras | Verweise



' Klein- und Grossschreibung wird berücksichtig: luk <> Luk



'Alternative:



'Doubletten entfernen

'Idee:

'- Wenn es eine Word-Tabelle ist, oder die Adressen sauber mit Tabstops gebaut sind:

'- die Adressen ins Excel übertragen

'- dort Menü Daten|Filter|Speialfilter..

'- bei Kriterienbereich die gewünschten Spalten angeben; markieren oder eingeben z. B. Tabelle1!$A:$B;Tabelle1!$D:$D

'- "an eine andere Stelle kopieren" aktivieren

'- "keine Duplikate" aktivieren

'- OK

'

'- danach die Daten im Excel lassen oder wieder zurück in eine Word-Tabelle setzen



Sub DoppelteEintraegeDerErstenSpalteDerErstenTabelleRotMarkieren()

    

    ' jede Zelle endet auf chr(13) & chr(7)

    

    ' Doppelte Eintraege Der Ersten Spalte Der Ersten Tabelle Rot Markieren

    ' Jedes mehrfache Vorkommen wird rot markiert (nicht nur ab dem zweiten)

    

    Dim strGanzeErsteSpalte     As String   ' ganze erste Spalte der ersten Tabelle

    Dim aCell                   As Cell     ' eine Zelle der ersten Spalte (Schleife)

    Dim strSuchwort             As String   ' Suchwort der Schleife

    Dim intPosErstesVorkommen   As Integer  ' Position erstes Vorkommen

    Dim intPosZweitesVorkommen  As Integer  ' Position zweites Vorkommen

    Dim strZellenEnde           As String   ' Zellenende

    Dim MyData

    

    

    strZellenEnde = Chr(13) & Chr(7)

    ' Inhalt erste Spalte übernehmen

    ActiveDocument.Tables(1).Columns(1).Select

    Selection.Copy

    

    strGanzeErsteSpalte = ""

    Set MyData = New DataObject

    

    MyData.GetFromClipboard

    strGanzeErsteSpalte = MyData.GetText(1)

    

    ' String vorne ergänzen

    strGanzeErsteSpalte = strZellenEnde & strGanzeErsteSpalte

    

'    toolAsciiShowMehrereAscii strGanzeErsteSpalte

    

    ' Ascii-Werte anpassen

    strGanzeErsteSpalte = Replace(strGanzeErsteSpalte, Chr(10), Chr(7))

    

'    toolAsciiShowMehrereAscii strGanzeErsteSpalte

    

    ' strGanzeErsteSpalte = Selection.Range.Text

    

    ' Auswahl kollabieren

    Selection.Collapse wdCollapseStart

    ' Clipboard leeren (nur noch ein Zeichen)

    Selection.MoveRight wdCharacter, 1, wdExtend

    Selection.Copy

    ' Auswahl kollabieren

    Selection.Collapse wdCollapseStart

    

    ' Alle Zellen der Spalte durchgehen

    For Each aCell In ActiveDocument.Tables(1).Columns(1).Cells

        ' Suchwort dieses Schleifendurchgangs (aktuelle Zelle)

        strSuchwort = aCell.Range.Text

        strSuchwort = strZellenEnde & strSuchwort

        ' Position des ersten Vorkommens ermitteln

        intPosErstesVorkommen = InStr(1, _

                                      strGanzeErsteSpalte, _

                                      strSuchwort)

        ' Gibt es ein erstes Vorkommen? Das sollte stets so sein.

        If intPosErstesVorkommen > 0 Then

            ' Gibt es ein zweites Vorkommen? Das wäre ein Duplikat.

            intPosZweitesVorkommen = InStr(intPosErstesVorkommen + Len(strSuchwort), _

                                           strGanzeErsteSpalte, _

                                           strSuchwort)

            ' Gibt es ein zweites Vorkommen? (ist die Position ab dem ersten Vorkommen > 0 ?)

            If intPosZweitesVorkommen > 0 Then

                ' Ja:

                ' MsgBox "Doppelt: " & strSuchwort

                ' rot markieren:

                aCell.Range.Font.Color = wdColorRed

            Else

                ' Tue nichts

            End If

        Else

            ' Programmfehler

            MsgBox "Programmfehler: Wort kommt nicht ein einziges Mal vor: " & strSuchwort, vbCritical

        End If

    Next

    

    MsgBox "Fertig", vbInformation

    

End Sub



'Private Function strFuncZellenInhalt(cellMyCell As Cell) _

'                                          As String

'

'    ' Liefert den Zellinhalt einer Zelle ohne

'    ' Absatzmarke und Zellenendzeichen.

'

'    strFuncZellenInhalt = Left(cellMyCell.Range.Text, _

'                               Len(cellMyCell.Range.Text) - 2)

'

'End Function

'

'Public Sub toolAsciiShowMehrereAscii(strMeinString As String)

'

'    Dim i

'    Dim strResultat

'

'

'    strResultat = strMeinString & _

'                  vbNewLine & _

'                  "--------------------" & _

'                  vbNewLine

'

'    For i = 1 To Min(50, Len(strMeinString))

'

'        strResultat = strResultat & vbNewLine & _

'                      Format(Str(i), "00") & _

'                      ":  " & _

'                      Mid(strMeinString, i, 1) & "  " & _

'                      Asc(Mid(strMeinString, i, 1))

'

'    Next i

'

'    MsgBox strResultat, _

'           vbInformation, _

'           "Ascii"

'

'End Sub

'

'Public Function Min(a, b)

'

'    If a < b Then

'        Min = a

'    Else

'        Min = b

'    End If

'

'End Function







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: