Exceltabelle auf bestimmte Wörter prüfen

Hallo,
wir haben folgendes Problem. Wir nutzen selber Exceltabellen, in denen wir unsere Produktbeschreibungen und Daten für unseren Onlineshop pflegen und diese dann in unsere Wawi importieren. Wir erhalten dort einige Beschreibungen von den Herstellern,
in denen Wörter aufgeführt sind, die wir nicht veröffentlichen dürfen.
Somit benötigen wir eine Abfrage, mit der wir die Listen nach diesen Wörtern kontrollieren können und dann anhand einer Markierung nachträglich bereinigen können.
mit der Tastenkombi Strg + F kann ich einzelne Wörter abfragen und suchen, doch benötigen wir eine bessere Lösung auf Basis einer Auflistung der problematischen Wörter, die nicht in den Beschreibungnen veröffentlicht werden dürfen.
Also wir hinterlegen dann wörter wie: Garantie,dauerhaft,perfekt und die Abfrage muss dann immer wenn diese Wörter oder Satzbausteine in der Tabelle vorhanden sind diese kennzeichnen, damit wir die Texte bearbeiten können. Basis muss dann eine Auflistung von Begriffen sein, nach denen gesucht wird. Wenn es neue Begriffe gibt, müssen die gepflegt werden und die Abfrage erkennen das auch nach den neuen Wörtern gesucht wird.
OPTIMAL wäre ein Tool, das auf knopfdruck eine Exceltabelle öffnet und nach den Wrtern sucht und dann makiert.
Viele Grüße
Frederik

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Forbidden() On Error GoTo Fehler Dim TB, SP As Integer, ZE As Integer, i As Long, LR As Long Dim Pfad As String, Datei As String, DLG, C, firstAddress Pfad = "C:\Temp\" SP = 1 'Spalte A ZE = 2 'ab Zeile 2 wegen Überschrift Application.ScreenUpdating = False With ThisWorkbook.Sheets("Tabelle1") LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte Set DLG = Application.FileDialog(msoFileDialogFilePicker) 'Datei wählen With DLG .AllowMultiSelect = False .InitialFileName = Pfad & "*.xlsx" .InitialView = msoFileDialogViewDetails 'Anzeige des Dialogs - die Dateien als Detail End With If DLG.Show = True Then Datei = DLG.SelectedItems(1) Workbooks.Open Filename:=Datei Set TB = ActiveWorkbook.Sheets(1) ' erste Blatt wird durchsucht For i = ZE To LR Set C = TB.Cells.Find(.Cells(i, SP), LookIn:=xlValues) If Not C Is Nothing Then firstAddress = C.Address Do With C.Interior 'Färben .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 .PatternTintAndShade = 0 End With Set C = TB.Cells.FindNext(C) Loop While Not C Is Nothing And C.Address <> firstAddress End If Next End If End With Fehler: If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

'* Anpassen***** Pfad = "C:\Temp\" 'der Pfad, der bei der Dateiauswahl vorgeschlagen wird Ext = "*.xlsx" ' Dateien dieser Endung werden voreingestellt SP = 1 'Spalte A / Hier stehen die Sperreinträge ZE = 2 'ab Zeile 2 wegen Überschrift '* Ende Anpassen*****

Sub Forbidden() On Error GoTo Fehler Dim TB, SP As Integer, ZE As Integer, i As Long, LR As Long Dim Pfad As String, Datei As String, Ext As String Dim Suchwort As String, Länge As Integer, DLG, C Dim firstAddress As String, AbWo As Integer '* Anpassen***** Pfad = "C:\Temp\" 'der Pfad, der bei der Dateiauswahl vorgeschlagen wird Ext = "*.xlsx" ' Dateien dieser Endung werden voreingestellt SP = 1 'Spalte A Hier sind die Sperreintrage ZE = 2 'ab Zeile 2 wegen Überschrift '* Ende Anpassen***** Application.ScreenUpdating = False With ThisWorkbook.Sheets(1) LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte Set DLG = Application.FileDialog(msoFileDialogFilePicker) 'Datei wählen With DLG .AllowMultiSelect = False .InitialFileName = Pfad & Ext .InitialView = msoFileDialogViewDetails 'Anzeige des Dialogs - die Dateien als Detail End With If DLG.Show = True Then Datei = DLG.SelectedItems(1) Workbooks.Open Filename:=Datei Set TB = ActiveWorkbook.Sheets(1) ' erste Blatt wird durchsucht For i = ZE To LR Suchwort = .Cells(i, SP) Länge = Len(Suchwort) Set C = TB.Cells.Find(Suchwort, LookIn:=xlValues) If Not C Is Nothing Then firstAddress = C.Address Do With C AbWo = InStr(1, C.Text, Suchwort) .Characters(Start:=AbWo, Length:=Länge).Font _ .Color = -16776961 End With Set C = TB.Cells.FindNext(C) Loop While Not C Is Nothing And C.Address <> firstAddress End If Next End If End With Fehler: If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

So, hier nochmal eine Änderung
Bei einem Fund kommt eine Box, ob geändert werden soll
- bei Ja, öffnet sich eine Inputbox, hier kann das Wort getauscht werden.
- bei Nein, wird das Wort rot gefärbt
Zum Schluss kommt noch die Info über Anzahl der Fundstellen.

Sub Forbidden()
    On Error GoTo Fehler
    Dim TB, SP As Integer, ZE As Integer, i As Long, LR As Long
    Dim Pfad As String, Datei As String, Ext As String
    Dim Suchwort As String, Länge As Integer, DLG, C, JaNein
    Dim firstAddress As String, AbWo As Integer, j As Integer, k As Integer
    
    '* Anpassen***** 
    Pfad = "C:\Temp\" 'der Pfad, der bei der Dateiauswahl vorgeschlagen wird 
    Ext = "*.xlsx" ' Dateien dieser Endung werden voreingestellt 
    SP = 1 'Spalte A Hier sind die Sperreintrage 
    ZE = 2 'ab Zeile 2 wegen Überschrift 
    '* Ende Anpassen***** 
    
    Application.ScreenUpdating = False
    
    With ThisWorkbook.Sheets(1)
        LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte 
        
        Set DLG = Application.FileDialog(msoFileDialogFilePicker) 'Datei wählen 
        With DLG
            .AllowMultiSelect = False
            .InitialFileName = Pfad & Ext
            .InitialView = msoFileDialogViewDetails 'Anzeige des Dialogs - die Dateien als Detail 
        End With
        If DLG.Show = True Then
            Datei = DLG.SelectedItems(1)
            Workbooks.Open Filename:=Datei
            Set TB = ActiveWorkbook.Sheets(1) ' erste Blatt wird durchsucht 
            TB.Cells.Font.ColorIndex = xlAutomatic
            For i = ZE To LR
                Suchwort = .Cells(i, SP)
                Länge = Len(Suchwort)
Restart:
                Set C = TB.Cells.Find(Suchwort, LookIn:=xlValues)
                If Not C Is Nothing Then
                    firstAddress = C.Address
                    Do
                        j = j + 1
                        With C
                            JaNein = MsgBox(Suchwort & ": gefunden" & vbLf & vbLf & "Text ändern", vbQuestion + vbYesNo, "Fundstelle")
                            If JaNein = vbYes Then
                                TB.Range(C.Address) = InputBox(C.Text, "Text ändern", C.Text)
                                k = k + 1
                                GoTo Restart
                            Else
                                AbWo = InStr(1, C.Text, Suchwort)
                                .Characters(Start:=AbWo, Length:=Länge).Font _
                                    .Color = -16776961
                            End If
                        End With
                        Set C = TB.Cells.FindNext(C)
                    Loop While Not C Is Nothing And C.Address <> firstAddress
                End If
            Next
        End If
    End With
    MsgBox "Es wurden " & j & " Badwords gefunden" & vbLf & vbLf & _
           k & " davon wurden geändert"

Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

Sub Forbidden() On Error GoTo Fehler Dim TB, SP As Integer, ZE As Integer, i As Long, LR As Long Dim Pfad As String, Datei As String, DLG, C, firstAddress Pfad = "C:\Temp\" SP = 1 'Spalte A ZE = 2 'ab Zeile 2 wegen Überschrift Application.ScreenUpdating = False With ThisWorkbook.Sheets("Tabelle1") LR = .Cells(.Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte Set DLG = Application.FileDialog(msoFileDialogFilePicker) 'Datei wählen With DLG .AllowMultiSelect = False .InitialFileName = Pfad & "*.xlsx" .InitialView = msoFileDialogViewDetails 'Anzeige des Dialogs - die Dateien als _ Detail End With If DLG.Show = True Then Datei = DLG.SelectedItems(1) Workbooks.Open Filename:=Datei Set TB = ActiveWorkbook.Sheets(1) ' erste Blatt wird durchsucht For i = ZE To LR Set C = TB.Cells.Find(.Cells(i, SP), LookIn:=xlValues) If Not C Is Nothing Then firstAddress = C.Address Do With C.Interior 'Färben .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 .PatternTintAndShade = 0 End With Set C = TB.Cells.FindNext(C) Loop While Not C Is Nothing And C.Address firstAddress End If Next End If End With Fehler: If Err.Number 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Beliebteste Forumthreads (12 Monate)

Exceltabelle auf bestimmte Wörter prüfen

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Exceltabelle auf bestimmte Wörter prüfen

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread