Formatierungsmakro erweitern

Guten Abend,
meine VBA Kenntnisse beschränlen sich leider auf den Rekorder und höchstens noch löschen, was nicht benötigt wird, daher bitte ich um eure Hilfe, mein Makro weiter zu vervollständigen. Ich denke zu dem bisherigen Makro braucht es keine großen Worte, ich denke für Profis ist das selbsterklärend.
https://www.herber.de/bbs/user/157828.xlsm
Zu erst einmal eine Frage. Ich sehe es richtig, das Makro passt immer nur die Zelle an, in der sich etwas gändert hat, nicht jedes mal die ganze Tabelle? Wenn ja soll das bitte auch so bleiben, wenn nein, wäre es super wenn sich das ändert.
2. Die Texte in Spalte B haben durchs kopieren aus dem Internet oft noch ein Leerzeichen am Schluss, kann man in das Makro etwas einbauen, was dieses Leerzeichen löscht, sobald ich einen Text in Spalte B einfüge? (betrifft nur Spalte B).
3. Lässt sich noch folgendes einbauen: Wenn ich in Spalte A ganz am Ende einen Text einfüge, den es bereits in Spalte A gibt, wäre es schön, wenn das Makro diesen sofort wieder löscht und dann in die Zelle springt, in der der Text bereits steht. (Falls er noch öfter vorkommt, ist es mir egal in welche Zelle das Makro springt).
Wäre toll, wenn ihr mir helft. Danke
Christian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Herbert,
danke erstmal für deine Mühe.
Ich habe ein kleines Problem, was ich mir selbst nicht erklären kann, mehrere Dinge haben in meiner originalen Datei noch funktioniert aber in beiden hochgeladenen Dateien nicht mehr. Kannst du mal danach schauen woran das liegt?
1. Ich kann keine Zeilen mehr löschen / einfügen ohne das ein Fehler kommt.
2. ich kann keinen Text aus der Tabelle mehr kopieren und gleichzeitig in mehrere andere Zellen einfügen ohne dass ein Fehler kommt.
Nun zu deinem Makro. Ich habe versucht mehrere Sachen anzupassen, schau bitte mal ob ich alles richtig gemacht habe

Private Sub Worksheet_Change(ByVal Target As Range)
    With Selection
        .Font.Italic = True
        .Font.Bold = False
        .Font.Name = "Calibri"
        .Font.Size = 11
        .HorizontalAlignment = xlCenter
    End With
    
    Cells.EntireColumn.AutoFit
    
    If Right(Selection, 1) = " " Then Target.Value = Left(Target.Value, Len(Target.Value) - 1)
    
    lLastrow = Cells(Rows.Count, "B").End(xlUp).Row - 1
    
    If Application.WorksheetFunction.CountIf(Worksheets("Tabelle1").Range("A2:A" & lLastrow), Target.Value) > 0 And Target.Value > Range("A" & lLastrow - 1).Value Then
         lRowFind = Application.Match(Target.Value, Range("A2:A" & lLastrow), 0) + 1
         Cells(lLastrow + 1, 1).ClearContents
         Cells(lRowFind, 1).Select
    End If
End Sub

Das erste was ich machen wollte ist dass nicht Spalte B auf mehrfache Einträge geprüft wird, sondern Spalte A.
Das zweite war dass bei gefundenen Mehrfacheinträgen der soeben eingegebene Text gelöscht werden sollte, daher habe ich die Zeile

Cells(lLastrow + 1, 1).ClearContents

eingefügt.
Das dritte (ich weiß das wurde bislang noch nicht angesprochen), ich dupliziere öfters die Daten zu den Filmen, eben wenn ich Einträge für mehrere Schauspieler machen will, daher habe ich die Prüfung And Target.Value > Range("A" & lLastrow - 1).Value eingefügt, damit dies auch in Spalte A möglich ist, das ich den letzten Eintrag nehme und diesen in weitere Zeilen kopieren kann.
Schaust du bitte mal?
Danke
Christian

Private Sub Worksheet_Change(ByVal Target As Range) Dim lRowFind&, lLastRow& If Target.Count > 1 Then GoTo ende With Selection .Font.Italic = True .Font.Bold = False .Font.Name = "Calibri" .Font.Size = 11 .HorizontalAlignment = xlCenter End With Cells.EntireColumn.AutoFit '* letzte belegte Zeile ermitteln lLastRow = Cells(Rows.Count, "A").End(xlUp).Row - 1 '* wenn Zeile gelöscht oder Text kopiert werden soll, dann hier Abbruch If Target.Row > lLastRow + 1 Then GoTo ende '* rechtes Leerzeichen (Blank) entfernen If Right(Selection, 1) = " " Then Target.Value = Left(Target.Value, Len(Target.Value) - 1) Application.EnableEvents = False '* erste Zelle mit dem Suchbegriff anspringen If Application.WorksheetFunction.CountIf(Worksheets("Tabelle1").Range("A2:A" & lLastRow), Target.Value) > 0 Then lRowFind = Application.Match(Target.Value, Range("A2:A" & lLastRow), 0) + 1 Rows(Target.Row).EntireRow.Delete Cells(lRowFind, "A").Select End If ende: Application.EnableEvents = True End Sub

Beliebteste Forumthreads (12 Monate)

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread