Hallo Josef,
leider musst du jetzt ins Archiv schauen, denke aber, wirst das schon finden. Habe weitergekramt und noch 'ne andere udF gefunden. Die in Kombination mit 2 anderen udFs liefert für mein Testbsp das gleiche Ergebnis wie du hier sehen kannst:
Die 3 udFs folgen hier, damit du sie kopieren kannst. Die beste Methode zu ihrer universalen Anwendung wäre es, eine leere Mappe mit 1 Blatt anzulegen, der einen aussagekräftigen Namen zu geben, im Makroeditor diesem "Projekt" ein Modul hinzuzufügen und die 3 Funktionen hineinzukopieren. Anschließend in den Eigenschaften des Projekts "AddIn" auf "True" setzen und das Ganze in den Ordner ...Office\Makro speichern (Macros ist für Word!).
Dann nicht vergessen in deiner anwendenden Mappe den Namen WVgl zu definieren, in dessen Formelteil die blaue Formel lt Abbild steht (ab "="). WVgl wird somit zur benannten Formel. Das ist wichtig, weil sonst die bedingte Formatierung nicht funktioniert (arbeitet nicht mit Externbezügen)! Dabei sollte die 1.Zelle, von der aus du auch die bedingte Formatierung über die Tabelle ausdehnst, markiert sein (sonst stimmen Bezüge nicht). Falls du deine Leerzeilen beibehalten willst, musst du das Ganze entsprechend anpassen.
Rem Anzahl des Auftretens einer Zeichenfolge in einer anderen
' Autor: Luc - 1.Publ: www.herber.de - 20061218
Function CountOn(ByVal ZFolge As String, _
ByVal ZKomb As String) As Integer
Dim i As Integer, k As Integer
k = Len(ZKomb)
If Len(ZFolge) < k Then Exit Function
For i = 1 To Len(ZFolge)
If Mid(ZFolge, i, k) = ZKomb Then
CountOn = CountOn + 1
i = i + k - 1
End If
Next i
End Function
Rem Schnittmenge 2er Listen als Text (ErgebnisLi enthält nur Elemente, die in bd Li auftret)
' Autor: Luc - 1.Publ: www.herber.de - 20061218
Function SMenge(ByVal M1 As String, ByVal M2 As String, _
Optional TrennZ As Variant) As String
Dim i As Long, j As Long, k As Long, l As Long, _
ltz As Integer, m() As Integer, n() As Integer, tm As Variant
On Error Resume Next
If IsMissing(TrennZ) Then
TrennZ = " "
End If
ltz = Len(TrennZ)
i = Len(M1): j = Len(M2)
ReDim m(i) As Integer, n(j) As Integer
m(0) = 1 - ltz
n(0) = 1 - ltz
M1 = M1 & TrennZ
For i = 1 To Len(M1)
If Mid(M1, i, ltz) = TrennZ Then
k = k + 1: m(k) = i
End If
Next i
M2 = M2 & TrennZ
For i = 1 To Len(M2)
If Mid(M2, i, ltz) = TrennZ Then
l = l + 1: n(l) = i
End If
Next i
For i = 1 To k
tm = Mid(M1, m(i - 1) + ltz, m(i) - m(i - 1) - ltz)
For j = 1 To l
If tm = Mid(M2, n(j - 1) + ltz, n(j) - n(j - 1) - ltz) Then
SMenge = SMenge & TrennZ & tm
Exit For
End If
Next j
Next i
If SMenge = "" Then Exit Function
SMenge = Mid(SMenge, ltz + 1)
End Function
Rem vereinigt (unterschiedliche) (Teil-)Inhalte der Zellen von Bereich zu einem String
' Autor: Luc - 1.Publ: www.herber.de - 20061218
Function ChainOn(ByVal Bereich As Variant, Optional ByVal BindeZ As Variant, _
Optional ByVal nurUngleiche As Variant, _
Optional ByVal inLänge_bisPos_vorZ As Variant, _
Optional ByVal abPos_nachZ As Variant) As Variant
Dim i As Integer, z As Boolean, y As String, yk As String, x As Object
If Not IsObject(Bereich) Then
ChainOn = ""
Exit Function
End If
If IsMissing(BindeZ) Then
BindeZ = ""
End If
If IsMissing(nurUngleiche) Then
nurUngleiche = False
Else: nurUngleiche = CBool(nurUngleiche)
End If
For Each x In Bereich
If IsMissing(inLänge_bisPos_vorZ) And IsMissing(abPos_nachZ) Then
If x.NumberFormat <> "General" Then
y = Trim(WorksheetFunction.Text(x.Value, x.NumberFormatLocal))
Else: y = x.Value
End If
Else
If IsNumeric(x.Value) Then
y = Trim(x.Value)
Else: y = x.Value
End If
y = PartOf(y, abPos_nachZ, inLänge_bisPos_vorZ)
If BindeZ <> "" And Len(y) > 0 Then
While Left(y, Len(BindeZ)) = BindeZ
y = Right(y, Len(y) - Len(BindeZ))
Wend
While Right(y, Len(BindeZ)) = BindeZ
y = Left(y, Len(y) - Len(BindeZ))
Wend
End If
End If
If y <> "" Then
If nurUngleiche And InStr(ChainOn, y) > 0 Then GoSub nu
ChainOn = dIf(ChainOn = "", y, dIf(nurUngleiche And y = "", _
ChainOn, ChainOn & BindeZ & y))
End If
Next x
If ChainOn = BindeZ Or ChainOn = "" Then
ChainOn = ""
ElseIf Right(ChainOn, 1) = BindeZ Then
ChainOn = Left(ChainOn, Len(ChainOn) - 1)
Else: ChainOn = Trim(ChainOn)
End If
Exit Function
nu: If IsMissing(BindeZ) Then Return
If InStr(ChainOn, BindeZ) > 0 Or y = ChainOn Then 'Entfernen v.MehrfachKompp
i = 1
While i <= Len(y)
yk = PartOf(Mid(y, i) & BindeZ, 1, BindeZ)
If ListOp(y, "ceq", yk, BindeZ) > 1 Then 'Prüfung innerhalb von y
y = Left(y, i - 1) & Mid(y, i + _
Len(yk) + Len(BindeZ))
ElseIf ChainOn <> "" Then 'Vgl der y-Kompp m.schon exist ChainOn-Wert
If ListOp(ChainOn, "ceq", yk, BindeZ) > 0 Then
y = Left(y, i - 1) & Mid(y, i + _
Len(yk) + Len(BindeZ))
Else
i = i + Len(yk) + Len(BindeZ)
End If
Else
i = i + Len(yk) + Len(BindeZ)
End If
Wend
End If
Return
co: y = Left(y, i - 1) & Mid(y, i + Len(yk) + Len(BindeZ))
Return
End Function
Viel Spaß und schönes WE
Luc :-?