Zweites Wort der Zelle fett

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count = 1 And Target.Column = 1 Then Target.Characters(Start:=InStr(Target, " ") + 1, Length:=Len(Target)).Font.Bold = True End If End Sub

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count = 1 And Target.Column = 2 Then Target.Font.Bold = False If InStr(Target, " ") > 0 Then Target.Characters(Start:=InStr(Target, " ") + 1, Length:=InStr(InStr(Target, " ") + _ 1, Target, " ") - InStr(Target, " ")).Font.Bold = True End If End If End Sub

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) ' Zweites Wort Fet, Bereich A2:D100 If Target.Count = 1 And Target.Column = 2 And Target.Row 0 Then Target.Characters(Start:=InStr(Target, " ") + 1, Length:=InStr(InStr(Target, " ") + _ 1, Target, " ") - InStr(Target, " ")).Font.Bold = True End If End If End Sub

Hallo Sandra,
bin zwar nicht Erich, aber macht nichts ;-))

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rngTarget As Range, rng As Range, intS As Integer, intE As Integer

  Set rngTarget = Intersect(Target, Range("A2:D100"))
  If Not rngTarget Is Nothing Then
    For Each rng In rngTarget
      intS = InStr(1, rng, " ")
      If intS > 0 Then
        intE = InStr(intS + 1, rng, " ")
        rng.Characters(intS + 1, IIf(intE > 0, intE - intS - 1, 99)).Font.Bold = True
      End If
    Next
  End If
  Set rngTarget = Nothing
End Sub

Gruß Sepp

Hi Sandra,
hier noch ne Version (nachdem ich ja schon mal vorkam... ;-)):


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngB As Range, rngC As Range, strT As String, arrT, pp As Long
Set rngB = Intersect(Target, Range("A2:D100"))
If rngB Is Nothing Then Exit Sub
For Each rngC In rngB.Cells
strT = rngC.Text
pp = InStr(strT, " ") + 1
If pp > 1 Then
arrT = Split(strT, " ")
rngC.Font.Bold = False
rngC.Characters(pp, Application.Max(1, Len(arrT(1)))).Font.Bold = True
End If
Next rngC
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zweites Wort der Zelle fett

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread