Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
748to752
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
748to752
748to752
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zusammengeschusterter Code

Zusammengeschusterter Code
26.03.2006 22:14:18
Bluey
Um das Projekt zu testen, muss in dem aktiven Worksheet die Zelle "a1" mit unterschiedlich gefärbten Text vorkommen.
Wenn ihr das Projekt kompiliert, treten Probleme mit den Arrays auf, weshalb
ich mein Projekt hier veröffentliche!
P.S.: Ihr solltet die gefärbten Textpassagen in der Zelle mit dem Color-Index 15
färben, da sonst Probleme entstehen könnten, da ich noch nicht alle Indize definiert habe!
THANX FPR HELP!
MFG
BLEUY
[code]

Sub ProjektAusprobieren()
Dim Beginners As Variant
Dim Enders As Variant
Dim Colors As Variant
Beginners = Array("<blau>", "<rot>")
Enders = Array("</blau>", "</rot>")
Colors = Array(5, 7)
GetColorCellText Range("A1"), Colors, Beginners, Enders
End Sub

Public

Sub GetColorCellText(TRange As Range, ColorDescriptors As Variant, _
BeginDescriptors As Variant, EndDescriptors As Variant)
Dim BeginPushes()
Dim EndPushes()
Dim ColorPushes()
i = 0
Inputsource = TRange.Text
Char = 0
While Char < UBound(ColorDescriptors)
While Char < Len(Inputsource) 'Jedes Zeichen - nicht mehr als die.
Char = Char + 1
Length = Char 'Neuer Versuch
If TRange.Characters(Char, Length). _
Font.ColorIndex = ColorDescriptors(i) Then
BeginPushes(UBound(EndPushes)) = Char 'Dem Array anfügen
ColorPushes(UBound(ColorPushes)) = i 'Den Index des besagten Colors anfügen
End If
CharEndPos = Char
Do 'Anzahl betroffener Zeichen ermitteln
CharEndPos = CharEndPos + 1
If TRange.Characters(CharEndPos, 1). _
Font.ColorIndex <> ColorDescriptors(i) Then
EndPushes(UBound(EndPushes)) = CharEndPos 'Dem Array anfügen
Exit Do
End If
Loop
Wend
Wend
Workstack = Inputsource
While element < UBound(EndPushes) 'Jeden Push-Array durchlurchen
Workstack = PushString(CStr(Workstack), CStr(BeginPushes(element)), 1, CStr(BeginDescriptors(ColorPushes(element)))) 'BeginDescriptor in den Text
Workstack = PushString(CStr(Workstack), CStr(EndPushes(element)), 1, CStr(EndDescriptors(ColorPushes(element)))) 'EndDescriptorsDescriptor in den Text
element = element + 1
Wend
MsgBox "RESULT: " & Workstack
End Sub

Public

Function PushString(Sourcestring As String, BeginPos As Integer, EndPos As Integer, InputString As String)
FirstStack = Left(Sourcestring, EndPos)
EndStack = Right(Sourcestring, BeginPos)
PushString = FirstStack & InputString & EndStack
End Function

[/code]

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
WILL MIR DENN KEINER HELFEN :(
28.03.2006 17:55:48
Bluey
?
WIeso will denn keiner helfen?
AW: WILL MIR DENN KEINER HELFEN :(
28.03.2006 19:26:30
Gerd
Hi,
wenn du hier nervst, hilft dir das auch nicht. Vielleich versteht ja niemand das Problem?
mfg Gerd

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige