VBA - Texte nicht berücksichtigen

Hallo,
ich wäre euch sehr dankbar, wenn ihr mir helft, das Makro in der folgenden Datei abzuändern, welches den Filmtitel und die in dem Film genannten Schauspieler auflistet:
https://www.herber.de/bbs/user/156445.xlsm
Bevor ich hier viele Worte verliere, wie das Makro funktioniert und diese nur in die Irre führen, kopiert einfach den Inhalt der Spalte R in die Spalte B, dann startet das Makro automatisch und ihr seht das Ergebnis.
Aber jetzt zu meiner Bitte, ist es möglich dass das Makro die Texte die ich mit roter Farbe versehen habe überspringt, mit der Begründung, dass jeweils der Text 2 Zeilen drunter (gelbe Farbe) das Wort Double enthält?
Das andere was das Makro macht wie die zusätzliche Zeile einfügen oder die Möglichkeit bietet, dass ich den Text überall in Spalte B einfügen kann soll so bleiben.
Danke für eure Hilfe
Christian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Christian
Das Fehlerhandling gefällt mir, der Rest nicht so :)
Den Index-Zähler während einer laufenden For-Next Schleife zu ändern, sollte wenn möglich vermieden werden. Es macht die Angelegenheit unübersichtlich und schwer nachzuvollziehen. Andererseits: "never change a running system". Ich habe den Code im Grundsatz beibehalten.
Beachte die Zeilen:


If InStr(Target.Cells(i).Offset(2), "double") = 0 Then
End If


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Dim RNG As Range, TMP As String, MMAx As Integer
Dim Z0 As Integer, Z1 As Integer, Sp As Integer, i As Long
'Nur Spalte B berücksichtigen
Set RNG = Intersect(Columns(2), Target)
Z0 = 3 'Erster Durchlauf aus 3. Wert
Z1 = 2 'StartZeile im Bereich
MMAx = 132
If Target.Column = 2 And Target.Columns.Count = 1 And Target.Rows.Count > 1 Then
If WorksheetFunction.CountBlank(RNG) = RNG.Count Then Exit Sub ' falls nur Leerzellen
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = Z0 To RNG.Count Step 4
TMP = Target.Cells(i) 'der aktuelle Text
If InStr(Target.Cells(i).Offset(2), "double") = 0 Then
If i = Z0 Then i = Z0 - 5 ' von 2 auf 3 ändern
'Zählen, ob Text schon im Zielbereich vorhanden idt
If WorksheetFunction.CountIf(Target.Cells(1).Resize(1, Sp + 1), TMP) = 0 Then
'wenn neu, dann anfügen
Target.Cells(1).Offset(0, Sp) = TMP
Sp = Sp + 1
End If
End If
Next
'Einfügebereich löschen, außer erste Zelle
RNG.Offset(1, 0).Resize(RNG.Count - 1).ClearContents
'Leerzeile
If RNG.Count > MMAx Then
Rows(Target.Row + 1).Insert
End If
Application.EnableEvents = True
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number  0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

cu
Chris

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Fehler Const APPNAME = "Worksheet_Change" Dim RNG As Range, i As Integer, j As Integer Dim arBereich() As Variant ReDim arAusgabe(0) As Variant If Target.Column = 2 And Target.Columns.Count = 1 And Target.Rows.Count > 1 Then Set RNG = Intersect(Columns(2), Target) If WorksheetFunction.CountBlank(RNG) = RNG.Count Then Exit Sub ' Bereich an Array übergeben arBereich() = Application.Transpose(RNG.Value) For i = LBound(arBereich) To UBound(arBereich) Step 4 If InStr(arBereich(i + 3), "double") = 0 Then ' Filmtitel aufnehmen arAusgabe(0) = arBereich(i + 2) ' Prüfung Duplikate For j = LBound(arAusgabe) To UBound(arAusgabe) If arAusgabe(j) = arBereich(i + 1) Then Exit For Next j ' Person aufnehmen, wenn kein Duplikate If j > UBound(arAusgabe) Then ReDim Preserve arAusgabe(UBound(arAusgabe) + 1) arAusgabe(UBound(arAusgabe)) = arBereich(i + 1) End If End If Next i ' Array zurück in Tabelle schreiben If UBound(arAusgabe) > 0 Then Application.EnableEvents = False RNG.ClearContents Range("B1").Resize(1, UBound(arAusgabe) + 1) = arAusgabe Application.EnableEvents = True End If End If Exit Sub Fehler: Application.EnableEvents = True MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Fehler Const APPNAME As String = "Worksheet_Change" Const MMax As Integer = 132 Dim RNG As Range, i As Integer, j As Integer Dim arBereich() As Variant ReDim arAusgabe(0) As Variant If Target.Column = 2 And Target.Columns.Count = 1 And Target.Rows.Count > 1 Then Set RNG = Intersect(Columns(2), Target) If WorksheetFunction.CountBlank(RNG) = RNG.Count Then Exit Sub ' Bereich an Array übergeben arBereich() = Application.Transpose(RNG.Value) For i = LBound(arBereich) To UBound(arBereich) Step 4 If InStr(arBereich(i + 3), "double") = 0 Then ' Filmtitel aufnehmen arAusgabe(0) = arBereich(i + 2) ' Prüfung Duplikate For j = LBound(arAusgabe) To UBound(arAusgabe) If arAusgabe(j) = arBereich(i + 1) Then Exit For Next j ' Person aufnehmen, wenn kein Duplikate If j > UBound(arAusgabe) Then ReDim Preserve arAusgabe(UBound(arAusgabe) + 1) arAusgabe(UBound(arAusgabe)) = arBereich(i + 1) End If End If Next i ' Array zurück in Tabelle schreiben If UBound(arAusgabe) > 0 Then Application.EnableEvents = False RNG.ClearContents Cells(Target.Row, 2).Resize(1, UBound(arAusgabe) + 1) = arAusgabe If RNG.Count > MMax Then Rows(Target.Row + 1).Insert Application.EnableEvents = True End If End If Exit Sub Fehler: Application.EnableEvents = True MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Beliebteste Forumthreads (12 Monate)

VBA - Texte nicht berücksichtigen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread