Mit VBA Zellen löschen

[Ubi5]

Hallo vielleicht kann jemand mir bitte weiterhelfen Danke!
Ich möchte gern folgenden Ablauf:
Wenn ich in der Tabellel1 Spalte a eine Zahl lösche, dann sollen auch die Nachbarzellen B bis M gelöscht werden – gleichzeitig soll aber auch in der Tabelle2 Spalte a die gleiche
 Zahl wie in der Tabelle1 auch wenn sie öfter vorkommt inclusive der Nachbarzellen c bis f gelöscht werden.
 
Diese Anweisung funktioniert nur für den 1. Teil
 
Private Sub Worksheet_Change(ByVal Target As Range)
    ' Prüfen, ob sich die Änderung in Spalte A befindet und die Zelle leer wurde
    If Target.Column = 1 And Target.Cells.Count = 1 And IsEmpty(Target.Value) Then
        ' Bereich B bis M in der gelöschten Zeile löschen
        ' Stellen Sie sicher, dass keine Fehlermeldungen auftreten, wenn Sie mehrere Zellen gleichzeitig löschen
        On Error Resume Next
        Me.Range("B" & Target.Row & ":M" & Target.Row).Delete Shift:=xlUp
        On Error GoTo 0
    End If
End Sub
 
In der angefügten Datei wird die gelöschte Zahl in der Tabelle1 auch in der Tabelle2 gelöscht aber nur einmal.
 
Lg Ubi5

[Klaus-Dieter]

Hallo,

stellt sich für mich (wieder einmal) die frage, warum werden Daten, die offenbar irgendwie zusammen gehören, auf zwei Blättern gehalten?

[Andreas Killer]

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim OldValue
  Dim Where As Range, All As Range
  Dim FirstAddress As String

  'Nur wenn eine Zelle geändert wurde
  If Target.Count > 1 Then Exit Sub
  'Nur in Spalte A
  Set Target = Intersect(Target, Me.Range("A:A"))
  If Target Is Nothing Then Exit Sub
  'Nur wenn leer
  If Not IsEmpty(Target) Then Exit Sub

  'Zurück ändern, Wert holen, und wieder herstellen
  Application.EnableEvents = False
  Application.Undo
  OldValue = Target
  Application.Undo

  'Suche alle Zellen in dem anderen Blatt
  With Worksheets("Tabelle2").Range("A:A")
    Set Where = .Find(OldValue, LookIn:=xlValues, LookAt:=xlWhole)
    'Gefunden?
    If Not Where Is Nothing Then
      'Alle suchen
      FirstAddress = Where.Address
      Do
        If All Is Nothing Then Set All = Where Else Set All = Union(All, Where)
        Set Where = .FindNext(Where)
      Loop Until Where.Address = FirstAddress
      'Inhalte löschen
      Intersect(All.EntireRow, .Parent.Range("B:M")).ClearContents
    End If
  End With
  Application.EnableEvents = True
End Sub

[slowboarder]

Hi

so vielleicht:

Code:

Dim oldValue As Variant

' Speichert den Wert vor der Änderung, um ihn beim Löschen zu kennen
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("A:a")) Is Nothing Then
        oldValue = Target.Value
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim foundCell As Range
   
    ' Prüfen, ob die Änderung in Spalte A (1-100) erfolgte und gelöscht wurde
    If Not Intersect(Target, Me.Range("A:a")) Is Nothing Then
        If Target.Cells.Count = 1 Then ' Nur bei Einzelzellen
            If IsEmpty(Target) And oldValue <> "" Then
                ' in Tabelle1 zellen löschen
                Application.EnableEvents = False
                Target.Resize(, 13).ClearContents
                Application.EnableEvents = True
                ' In Tabelle2 nach dem alten Wert suchen und zellen löschen
                With Sheets("Tabelle2")
                    If WorksheetFunction.CountIf(.Columns(1), oldValue) Then
                        .Columns(1).Replace oldValue, True, xlWhole
                        Intersect(.Columns(1).SpecialCells(xlCellTypeConstants, 4).EntireRow, .Range("A:A,C:F")).ClearContents
                    End If
                End With
               
            End If
        End If
    End If
End Sub

hier wird in der Tabelle 2 der alte Wert zuerst durch ein WAHR ersetzt.
die Zellen mit einem Wahrheitswert kann man über die SpecialCells dann gezielt auswählen und bearbeiten.
damit spart man sich die ansonsten bei mehreren Werten notwendige Schleife.

Gruß Daniel

[snb]

mehrfach suchen = filtern

PHP-Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Count & Target.Column = "11" Then
      Application.Undo

      With Tabelle2.UsedRange
          .AutoFilter 1, Target
          .Columns(1).Offset(1).SpecialCells(12).EntireRow.Delete
          .AutoFilter
      End With
      Target.EntireRow.Delete
  End If
End Sub


[Egon12]

Hallo,
 
das ist u.U. vielleicht etwas abenteuerlich. Entweder man macht so was besser mit Doppelklick, im Sidemenü einen Button einbauen oder wenigstens noch eine Abbruchmöglichkeit um versehentliches Entfernen zu verhindern. 
 
Ich würde da aber eher einen Ribbontab + Editbox + Button einbauen. In die Editbox Zeilennummer eingeben und Button zum Ausführen. 
 
Beispiele wie man so was einbaut gibt es etliche in den Foren.
 
Gruß Uwe

[Egon12]

Hallo Ubi5,

da du für "löschen" Zellebereiche angegeben hast, hier die Variante mittels Eintragender Zeilennummer in eine Editbox im Ribbonband und Entfernen der Werte aller Funde per Button.

Um es schnell zu halten werden Treffer gesammelt entfernt. Da unglücklicherweise so eine Range-Variable nur bis 255 Zeichen funktioniert begrenzt sich der zu löschende in seiner möglichen Größe Block dahingehend.

Gelöscht werden natürlich alle Treffer.

Es gibt natürlich auch andere Methoden wie .Find, .Match etc. Hier mal eben dieser Weg.

  Mappe1(via Ribbon).xlsm (Größe: 20,49 KB / Downloads: 3)

Gruß Uwe

[Ubi5]

Hallo Daniel !
Hallo Uwe !

Beide Varianten funktionieren einwandfrei - werde beide Varianten eingehend testen.

Recht herzlichen Dank!



melde mich nochmals!!!

[Ubi5]

An - 
Daniel - deinen Code konnte ich in die Arbeitsmappe integrieren und funktioniert einwandfrei.
Egon - war nicht in der Lage deinen Vorschlag in die Arbeitsmappe zu integrieren.
Andreas - funktioniert leider nur zum Teil.
snb - konnte den Vorschlag leider nicht umsetzen.

Nochmals recht herzlichen Dank an alle für die Bemühungen.

Lg Ubi5