Thema: Text in Excel-Zelle teilweise fett

Wie kann man in Excel ein Wort in einem Text einer Zelle automatisch fett markieren, wenn dieses Wort in einer zweiten Tabelle in einer Spalte vorkommt?
Ich muss in Excel einen Teil (Name) eines Textes in einer Zelle fett markieren. In der gesamten Tabelle sind es über 100 Zeilen mit verschiedenen Namen, die jeweils in einer anderen Tabelle in einer Spalte stehen. (ich kann keinen Screenshot Vorher/Nachher hier einfügen.)
siehe Beispieldatei https://www.herber.de/bbs/user/175409.xlsx
Im Tabellenblatt "Publikationen" stehen in Spalte A untereinander (über 100 Zeilen) Texte, in denen gewisse Namen (stehen in Tabellenblatt "Tabelle2" in Spalte A) fett markiert werden sollen.
Lässt sich das über ein Makro realisieren? Händisch ist das doch sehr zeitaufwändig.

Vielen Dank im Voraus
Barbara

Hallo Barbara,

das geht nur mit VBA. Aber auch nur bis zum Abschmieren. Excel ist eben keine Textverarbeitung.

Gruß Uwe

Moin, :-)

... so der Spur nach: ;-)
https://www.herber.de/bbs/user/175411.xlsb

Servus
Case

Hi Barbara

So?

Sub NamenFettMarkieren()

    Dim wsPublikationen As Worksheet

    Dim wsTabelle2 As Worksheet

    Dim zelle As Range

    Dim nameZelle As Range

    Dim name As String

    Dim startPos As Long



    Set wsPublikationen = ThisWorkbook.Sheets("Publikationen")

    Set wsTabelle2 = ThisWorkbook.Sheets("Tabelle2")



    ' Durch alle Zellen in Spalte A von "Publikationen" iterieren

    For Each zelle In wsPublikationen.Range("A1:A100") ' Passen Sie den Bereich nach Bedarf an

        If zelle.Value <> "" Then

            ' Durch alle Namen in "Tabelle2" iterieren

            For Each nameZelle In wsTabelle2.Range("A1:A100") ' Passen Sie den Bereich nach Bedarf an

                If nameZelle.Value <> "" Then

                    name = nameZelle.Value

                    startPos = InStr(1, zelle.Value, name, vbTextCompare)

                    ' Wenn der Name gefunden wird

                    While startPos > 0

                        zelle.Characters(startPos, Len(name)).Font.Bold = True

                        startPos = InStr(startPos + Len(name), zelle.Value, name, vbTextCompare)

                    Wend

                End If

            Next nameZelle

        End If

    Next zelle

End Sub

Gruss

Raimund

Vielen Dank für eure Antworten und Vorschläge 🤗.
Ich werde das alles nächste Woche testen und berichten, für welche Version ich mich entschieden habe.

Wünsche allen ein schönes Wochenende

Vielen Dank für das Makro, hat im großen und ganzen gut funktioniert 👍. Bei einigen Zellen wurde dann zwar der Text nach dem Name auch noch fett markiert, aber da das nicht so viele Zellen waren, konnte ich das problemlos händisch korrigieren.

Danke - Ich weiß Excel ist kein WORD, aber diese Liste muss als Exceltabelle (da steht natürlich nicht nur in einer Spalte etwas drin) erstellt werden.
Hatte mir erhofft, dass mir ein Excel-Makro-Profi hier mit einem Makro weiterhelfen kann. Meine VBA-Kenntnisse um selbst so ein Makro zu erstellen sind einfach zu bescheiden.

Markieren in der selben Spalte so:

Sub markierenInSpalteA()

    Dim i&, j&, iStart&, iLang&, arrM(): arrM = Tabelle2.UsedRange

    With Tabelle1

        For i = 4 To .Cells(Rows.Count, 1).End(xlUp).Row

            For j = LBound(arrM) To UBound(arrM)

                If InStr(1, .Cells(i, 1), arrM(j, 1), vbTextCompare) > 0 Then

                    iStart = InStr(1, .Cells(i, 1), arrM(j, 1), vbTextCompare)

                    iLang = Len(arrM(j, 1))

                    .Cells(i, 1).Characters(Start:=iStart, Length:=iLang).Font.FontStyle = "Fett"

                End If

            Next j

        Next i

    End With

End Sub

Gruß Uwe

für Spalte C so:

Sub kopierenMarkierenInSpalteC()

    Dim i&, j&, iStart&, iLang&, arrM(): arrM = Tabelle2.UsedRange

    With Tabelle1

        For i = 4 To .Cells(Rows.Count, 1).End(xlUp).Row

            '.Cells(i, 3) = .Cells(i, 1) 'falls erforderlich

            For j = LBound(arrM) To UBound(arrM)

                If InStr(1, .Cells(i, 1), arrM(j, 1), vbTextCompare) > 0 Then

                    iStart = InStr(1, .Cells(i, 1), arrM(j, 1), vbTextCompare)

                    iLang = Len(arrM(j, 1))

                    .Cells(i, 3).Characters(Start:=iStart, Length:=iLang).Font.FontStyle = "Fett"

                End If

            Next j

        Next i

    End With

End Sub

Gruß Uwe

Hallo,

hier noch die kompakten Versionen für Spalte A bzw Spalte C:

Option Explicit



Sub markierenInSpalteA()

    Dim i&, j&, arrM(): arrM = Tabelle2.UsedRange

    For i = 4 To Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row

        For j = LBound(arrM) To UBound(arrM)

            If InStr(1, Tabelle1.Cells(i, 1), arrM(j, 1), vbTextCompare) > 0 Then Tabelle1.Cells(i, 1).Characters(Start:=InStr(1, Tabelle1.Cells(i, 1), arrM(j, 1), vbTextCompare), Length:=Len(arrM(j, 1))).Font.FontStyle = "Fett"

        Next j

    Next i

End Sub



Sub markierenInSpalteC()

    Dim i&, j&, arrM(): arrM = Tabelle2.UsedRange

    For i = 4 To Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row

        For j = LBound(arrM) To UBound(arrM)

            If InStr(1, Tabelle1.Cells(i, 1), arrM(j, 1), vbTextCompare) > 0 Then Tabelle1.Cells(i, 3).Characters(Start:=InStr(1, Tabelle1.Cells(i, 1), arrM(j, 1), vbTextCompare), Length:=Len(arrM(j, 1))).Font.FontStyle = "Fett"

        Next j

    Next i

End Sub

Gruß Uwe

Vielen Danke für die VBA-Lösungen, haben beide funktioniert 👍