Zwei Bereiche Vergleichen und doppelte löschen

07.01.2025 10:58:33

Ralle97

Hallo

Ich bekomme mein Thema nicht gelöst, könnt Ihr mir helfen?
Vielen Dank

Beschreibung:

Range 1 = C11;E11;G11;I11;K11;M11;O11;Q11;S1
Range 2 = B11:B13 ; D11:D13 ; F11:F13 ; H11:H13 ; J11:J13 ; L11:L13 ; N11:N13 ; P11:P13 ; R11:R13

Es gibt viele leere Zellen, ein paar werden nach und nach in Range 2 eingetragen.
In Range 1 werden nach und nach alle Zellen befüllt (nur Zahlen)
Wenn z.B. eine 5 in Range 1 eingetragen wird, sollen alle 5er in Range 2 entfernt werden.

LG
Ralle

AW: Zwei Bereiche Vergleichen und doppelte löschen

07.01.2025 11:44:24

GerdL

Hallo Ralle,

der Code gehört ins Modul der Tabelle.

Private Sub Worksheet_Change(ByVal Target As Range)



Dim strRange1 As String

Dim strRange2 As String

Dim rngSearch As Range, rngC As Range



strRange1 = "C11:C11,E11:E11,G11:G11,I11:I11,K11:K11,M11:M11,O11:O11,Q11:Q11,S1:S1"

strRange2 = "B11:B13,D11:D13,F11:F13,H11:H13,J11:J13,L11:L13,N11:N13,P11:P13,R11:R13"



On Error GoTo Fin



If Not Intersect(Target, Range(strRange1)) Is Nothing Then

    Application.EnableEvents = False

    For Each rngSearch In Intersect(Target, Range(strRange1)).Cells

        If rngSearch > "" Then

            For Each rngC In Range(strRange2).Cells

                If rngC = rngSearch Then rngC.ClearContents

            Next rngC

        End If

    Next rngSearch

    End If

Fin:

Application.EnableEvents = True



End Sub

Gruß Gerd

AW: Zwei Bereiche Vergleichen und doppelte löschen

07.01.2025 11:53:13

daniel

HI
müsste per VBA gelöst werden
erstelle dir das Change-Eventmakro mit folgendem Code:

dim rng1 as Range

dim rng2 as Range

 

set rng1 = Range("C11;E11;G11;I11;K11;M11;O11;Q11;S1") 'bitte Semikolon durch Komma ersetzen, bin zu faul und habe nur deine angaben kopiert

set rng2 = Range("11:B13 ; D11:D13 ; F11:F13 ; H11:H13 ; J11:J13 ; L11:L13 ; N11:N13 ; P11:P13 ; R11:R13") 'dito



if not Intersect(Target, rng1) is nothing then

    Application.EnabelEvents = false

    rng2.Replace target(1).value, "", xlwhole

    Application.EnableEvents = true

end if

Gruß Daniel

Zwei Bereiche Vergleichen und doppelte löschen

07.01.2025 14:11:24

Ralle97

Hallo

VIELEN VIELEN DANK

Ich probiere es gleich mal aus...

DANKE GerdL
DANKE daniel

@GerdL

07.01.2025 14:34:30

Ralle97

Hallo

Es funktioniert super, DANKE!
Nur um noch zu lernen, eine Frage:

Ich habe es nun noch angepasst (Range3+4 hinzugefügt)

Macht man das so?
Oder könnte man das auch kürzer schreiben, um Platz zu sparen ;-) ?

DANKE

Private Sub Worksheet_Change(ByVal Target As Range)

Dim strRange1 As String
Dim strRange2 As String

Dim strRange3 As String
Dim strRange4 As String

Dim rngSearch As Range, rngC As Range

strRange1 = "C11:C11,E11:E11,G11:G11,I11:I11,K11:K11,M11:M11,O11:O11,Q11:Q11,S1:S1"
strRange2 = "B11:B13,D11:D13,F11:F13,H11:H13,J11:J13,L11:L13,N11:N13,P11:P13,R11:R13"

strRange3 = "I2:I2,I5:I5,I8:I8,I11:I11,I14:I14,I17:I17,I20:I20,I23:I23,I26:I26"
strRange4 = "H2:H28"

On Error GoTo Fin

If Not Intersect(Target, Range(strRange1)) Is Nothing Then
Application.EnableEvents = False
For Each rngSearch In Intersect(Target, Range(strRange1)).Cells
If rngSearch > "" Then
For Each rngC In Range(strRange2).Cells
If rngC = rngSearch Then rngC.ClearContents
Next rngC
End If
Next rngSearch
End If

If Not Intersect(Target, Range(strRange3)) Is Nothing Then
Application.EnableEvents = False
For Each rngSearch In Intersect(Target, Range(strRange3)).Cells
If rngSearch > "" Then
For Each rngC In Range(strRange4).Cells
If rngC = rngSearch Then rngC.ClearContents
Next rngC
End If
Next rngSearch
End If

Fin:
Application.EnableEvents = True

End Sub

AW: @GerdL

07.01.2025 16:03:50

daniel

Hi
kleiner Tipp: wenn ein Teilbereich nur aus einer Zelle besteht, muss man die auch nur einmal hinschreiben.

statt: strRange1 = "C11:C11,E11:E11,G11:G11,I11:I11,K11:K11,M11:M11,O11:O11,Q11:Q11,S1:S1"
reicht: strRange1 = "C11,E11,G11,I11,K11,M11,O11,Q11,S1"

wenn alle drei Zellbereiche gleich bearbeitet werden sollen, kannst du sie zu einem zusammenfassen.
das kannst du über die Adressen machen:

Range(strRange2 & "," & strRange3 & "," & strRange4)

oder, wie schon von Gerd gezeigt mit Union:

Union(Range(strRange2), Range(strRange3), Range(strRange4))

besser ist hier das Union. die erste Methode mit dem Verketten der Adresstexte funktioniert nur, solange die Gesamtadresse nicht länger als 255 Zeichen wird.

noch ne Anmerkung: die Zelle I11 kommt bei dir in beiden Bereichen vor (Eingabe und Löschen). Ist das gewollt oder ein Fehler?
Gruß Daniel

AW: Zwei Bereiche Vergleichen und doppelte löschen

07.01.2025 15:33:57

GerdL

Moin

Private Sub Worksheet_Change(ByVal Target As Range)



Dim strRange(1 To 4) As String



Dim rngSearch As Range, rngC As Range



strRange(1) = "C11:C11,E11:E11,G11:G11,I11:I11,K11:K11,M11:M11,O11:O11,Q11:Q11,S1:S1"



strRange(2) = "B11:B13,D11:D13,F11:F13,H11:H13,J11:J13,L11:L13,N11:N13,P11:P13,R11:R13"

strRange(3) = "I2:I2,I5:I5,I8:I8,I11:I11,I14:I14,I17:I17,I20:I20,I23:I23,I26:I26"

strRange(4) = "H2:H28"



On Error GoTo Fin



If Not Intersect(Target, Range(strRange(1))) Is Nothing Then

    Application.EnableEvents = False

    For Each rngSearch In Intersect(Target, Range(strRange(1))).Cells

        If rngSearch > "" Then

            For Each rngC In Union(Range(strRange(2)), Range(strRange(3)), Range(strRange(4))).Cells

                If rngC = rngSearch Then rngC.ClearContents

            Next rngC

        End If

    Next rngSearch

End If





Fin:

Application.EnableEvents = True



End Sub

Bei Verwendung der von Daniel gezeigten Replace-Methode könntest du die innere Schleife noch eindampfen.

Gruß Gerd

Zwei Bereiche Vergleichen und doppelte löschen

07.01.2025 16:08:16

Ralle97

Danke Euch beiden !!!
VG
Ralle

Zwei Bereiche Vergleichen und doppelte löschen

Forumthread: Zwei Bereiche Vergleichen und doppelte löschen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Zwei Bereiche Vergleichen und doppelte löschen

Forumthread: Zwei Bereiche Vergleichen und doppelte löschen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread