Texte mit Wort Thumbnail stehen lassen

Hallo,

eine kurze und knackige Frage, wie ich folgendes Problem lösen kann.

Ich habe einen Bereich von A3 bis WB2000. (600 Spalten)

Ich möchte alle Texte, die das Wort thumbnail beinhalten, sowie jeweils die 3 Texte die unterhalb eines dieser Texte stehen behalten, alle anderen Texte möchte ich löschen.
Wie geht das am Sinnvollsten?

Bsp: der Text in S28 beinhaltet das Wort Thumbnail, also soll der Bereich S28 bis S31 nicht gelöscht werden.
Das es Überschneidungen gibt, also der Bereich S29-S31 erneut das wort Thumbnail beinhaltet, ist ausgeschlossen.

Wie mache ich das?

Bspdatei

Die roten Texte sollen gelöscht werden, die schwarzen sollen beibehalten werden. Wie gesagt wenn ein Text das Wort thumbnail beinhaltet, soll dieser, sowie die 3 Zellen drunter behalten werden.
https://www.herber.de/bbs/user/164568.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Christian,

bei vernichtenden Aktionen ist es immer ratsam, zuerst mit einer Aktion zu testen, was die Daten nicht löscht. Es ist dann leichter den originale Zustand wiederzuherstellen:

Sub Markieren()

Dim Z As Range 'Z wie Zelle

Dim Text As String

Dim i

    On Error Resume Next 'weil wenn in der 3te Zeile etwas 3 Zeilen drüber gesucht wird, kracht es

    Worksheets("Tabelle1").Range("A3:R31").interion.Color = xlNone

    For Each Z In Worksheets("Tabelle1").Range("A3:R31")

        Text = ""

        For i = 0 To 3

            Text = Text & " " & Z.Offset(-i).Value 'macht aus der akt. Zelle "Z", und die 3 darüber einen Text

        Next

        If InStr(1, Text, "thumbnail", vbTextCompare) = 0 Then Z.Interior.ColorIndex = 3 'wenn der Text kein "thumbnail" enthält, machen

    Next

End Sub

Wenn man sich überzeugt hat, dass es taugt, dann richtig löschen (das Begriff "Sicherungskopie" ist ja bekannt...):

Sub Löschen()

Dim Z As Range 'Z wie Zelle

Dim Text As String

Dim i

    On Error Resume Next 'weil wenn in der 3te Zeile etwas 3 Zeilen drüber gesucht wird, kracht es

    For Each Z In Worksheets("Tabelle1").Range("A3:R31")

        Text = ""

        For i = 0 To 3

            Text = Text & " " & Z.Offset(-i).Value 'macht aus der akt. Zelle "Z", und die 3 darüber einen Text

        Next

        If InStr(1, Text, "thumbnail", vbTextCompare) = 0 Then Z.Clear 'wenn der Text kein "thumbnail" enthält, machen

    Next

End Sub

VG
Yal

Sub Löschen() Dim i, j, k Dim Arr Dim Erg Const cBereich = "A3:R31" On Error Resume Next 'weil wenn in der 3te Zeile etwas 3 Zeilen drüber gesucht wird, kracht es Arr = Worksheets("Tabelle1").Range(cBereich).value For j = LBound(Arr, 2) To UBound(Arr, 2) 'Spalten For i = UBound(Arr, 1) To LBound(Arr, 1) Step -1 'Zeilen, von unten hoch Erg = False For k = 0 To 3 Erg = CBool(InStr(1, Arr(i - k, j), "thumbnail", vbTextCompare)) If Erg Then i = i - k Exit For End If Next If Not Erg Then Arr(i, j) = "" Next Next Worksheets("Tabelle1").Range(cBereich).value = Arr End Sub

Sub lthumbnail_stehen_lassen() Dim SuTxt As String, j, lz1 As Long Dim rFind As Range, Adr1 As String SuTxt = "thumbnail" Columns("S").ClearContents 'Text "thumbnail" suchen Set rFind = Cells.Find(What:=SuTxt, After:=[a1], LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then Adr1 = rFind.Address Do 'immer 4 Zeilen mit Find markieren Cells(rFind.Row, "S").Resize(4, 1) = "Find" Set rFind = Cells.FindNext(rFind) Loop Until rFind.Address = Adr1 End If 'nicht markierte Zeilen Rückwärts löschen For j = lz1 To 3 Step -1 If Cells(j, "S") = Empty Then Rows(j).Delete shift:=xlUp End If Next j End Sub

Sub Unit() Const cstrBereich As String = "A3:R31" Dim S As Long, Z As Long, Arr As Variant Arr = Range(cstrBereich).Value For S = 1 To UBound(Arr, 2) Z = 1 Do If InStr(LCase(Arr(Z, S)), "thumbnail") Then Z = Z + 3 Else Arr(Z, S) = "" End If Z = Z + 1 Loop Until Z > UBound(Arr, 1) Next Range(cstrBereich).Value = Arr End Sub

Beliebteste Forumthreads (12 Monate)

Texte mit Wort Thumbnail stehen lassen

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread