Anzeige
Archiv - Navigation
1604to1608
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Funktion für Range aus Range "herausschneiden"

Funktion für Range aus Range "herausschneiden"
28.01.2018 15:21:39
Stefan
Hallo Ihr,
ich suche händeringend eine Möglichkeit, einen Range-Bereich (Einzelzelle oder Bereiche, auch Areas) aus einem anderen Rangebereich "herauszuschneiden", im Prinzip das Gegenteil der Union-Funktion. Die Schnittmenge ist im rückgelieferten Range-Bereich dann nicht mehr enthalten.
Das zu programmieren, geht für eine Einzelzelle noch gerade mit vertretbarem Rechenzeitaufwand, für Areas oder dergleich scheint mir das schier unmöglich.
Und ich muss immer wiederkehrend Range-Bereiche auswerten.
Übersehe ich vielleicht eine einfache Möglichkeit in Excel ?
Mit Intersect und Union ist es nicht hinzubekommen.
LG Stefan

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

Betreff
Datum
Anwender
Anzeige
AW: Funktion für Range aus Range "herausschneiden"
28.01.2018 15:31:58
Hajo_Zi
Hallo Stefan,
Set RaBereich = Intersect(RaBereich, Target)
If Not RaBereich Is Nothing Then

Ich gebe keinen Dank für eine Rückmeldung, da ich durch solche Beiträge nicht meine Beitragszahl erhöhen muss.
Also ich schreibe keine Beiträge mit dem Betreff "Gerne u. Danke für die Rückmeldung....."
Rückmeldung ist ja in der Heutigen Zeit nicht üblich und die wenigen die eine Rückmeldung geben,
mögen mir das verzeihen, das kein Danke für eine Rückmeldung kommt.
Beiträge von Werner, Luc, robert und folgende lese ich nicht.
Anzeige
vielleicht so
29.01.2018 07:33:02
KlausF
Hallo Stefan,
vergib den Bereichen jeweils einen Namen und probier mal:
Sub SubtractAB()
Dim a As Range, b As Range
Dim RetSheet As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set a = Range("a")
Set b = Range("b")
RetSheet = ActiveSheet.Name
Worksheets.Add.Name = "_AB_Temp_"
Range(a.Address).Value = 1
Range(b.Address).Clear
Sheets(RetSheet).Select (False)
Cells.SpecialCells(xlCellTypeConstants).Select
Worksheets("_AB_Temp_").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set a = Nothing
Set b = Nothing
End Sub
Gruß
Klaus
Anzeige
AW: Funktion für Range aus Range "herausschneiden"
28.01.2018 15:45:07
Sepp
Hallo Stefan,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub test()
deRange(Range("A1:H20"), Range("B9,B10,C11,C12,D13,D14,E14,E13,F12,F11,G10,G9,C3:C6,F3:F6")).Select
End Sub

Public Function deRange(Target As Range, Exclude As Range) As Range
Dim objRng As Range, objRangeNew As Range

For Each objRng In Target
  If Intersect(objRng, Exclude) Is Nothing Then
    If objRangeNew Is Nothing Then
      Set objRangeNew = objRng
    Else
      Set objRangeNew = Union(objRangeNew, objRng)
    End If
  End If
Next

If Not objRangeNew Is Nothing Then Set deRange = objRangeNew
End Function

Gruß Sepp

Anzeige
AW: Funktion für Range aus Range "herausschneiden"
28.01.2018 15:55:44
Luschi
Hallo Steffan,
bei mir geht das so:

Sub test1()
Dim rg0 As Range, rg1 As Range, rg2 As Range, _
rg3 As Range, rg4 As Range
'Vereinigung
Set rg1 = Union([aa], [bb], [cc])
Debug.Print rg1.Address
'gemeinsame Schnittmenge
Set rg2 = Intersect([aa], [bb], [cc])
Debug.Print rg2.Address
'alle Übrigen (alle ohne gemeinsame Schnittmenge)
'1 Auschluß-Funktion als Gegenteil von 'Intersect' ist mit auch nicht bekannt
For Each rg0 In rg1
If Intersect(rg0, rg2) Is Nothing Then
If rg4 Is Nothing Then
Set rg4 = rg0
Else
Set rg4 = Union(rg4, rg0)
End If
End If
Next rg0
Debug.Print rg4.Address
Set rg0 = Nothing: Set rg1 = Nothing: Set rg2 = Nothing
Set rg3 = Nothing: Set rg4 = Nothing
End Sub
Gruß von Luschi
aus klein-Paris
Anzeige
oT: Dein Telefonempfang ist gestört? owT
28.01.2018 16:01:33
...
Gruß Werner
.. , - ...
AW: oT: Dein Telefonempfang ist gestört? owT
28.01.2018 16:32:52
Stefan
Ich hatte es befürchtet dass es nur über Schleifengewurschtel geht :-(
Das zieht in meinem Anwendungsfall mit "dynamischen" Ranges leider sowas von die Handbremse.
Ich danke euch.
LG Stefan
AW: Funktion für Range aus Range "herausschneiden"
28.01.2018 22:07:31
Stefan
hier mal eine mögliche Lösung, die zumindest für meinen Fall schneller funzt als der Einzelzellencheck:
Ich invertiere den auszuschneidenden Teil über zusammenfügen Range darüber/darunter/links/rechts,
das Ergebnis ist dann die Schnittmenge mit Bereich, aus dem ausgeschnitten werden soll.
Das dann noch für alle Areas ... funzt
Public Function Cut(Total As Range, Extract As Range) As Range
Dim r As Range, i%
Set r = Total
i = 1
Do
Set r = CutArea(r, Extract.Areas.Item(i))
i = i + 1
Loop Until (r Is Nothing) Or (i > Extract.Areas.Count)
Set Cut = r
End Function
' **** Hilfsroutine für eine Einzelzelle/zusammenhängenden Bereich (Area) ****
Private Function CutArea(Total As Range, Extract As Range) As Range
Dim All As Range, Invers As Range, r As Range
Set Invers = Nothing
Set All = Total.Parent.Cells
' Bereich oberhalb von Extract
If Extract.Row > 1 Then Set Invers = All.Cells(1, 1).Resize(Extract.Row - 1, All.Columns. _
Count)
' Bereich links von Extract
If Extract.Column > 1 Then
Set r = All.Cells(Extract.Row, 1).Resize(Extract.Rows.Count, Extract.Column - 1)
If Invers Is Nothing Then Set Invers = r Else Set Invers = Union(Invers, r)
End If
' Bereich unterhalb von Extract
If Extract.Row + Extract.Rows.Count 
Grüße Stefan
Anzeige
AW: Funktion für Range aus Range "herausschneiden"
29.01.2018 06:09:36
Sulprobil
Also ich fand die Antwort von Hajo_Zi schon zielführend. Ansonsten mal nach Sulprobil und Rless googeln.
Schleifen sind schon ok. Man mus ja nicht wurschteln. Viele Grüße, Bernd P.
AW: Funktion für Range aus Range "herausschneiden"
29.01.2018 07:00:45
Stefan
die Antwort von Hajo_Zi funzt nicht, Intersect gibt ausschließlich die Schnittmenge wieder, nicht das Ergebnis was ich brauche. Sepp und Luschi haben hierzu eine Programmmöglichkeit gezeigt, Danke nochmal dafür. Problem ist dabei, dass dabei ALLE Zellen des Bereiches, aus dem ausgeschnitten werden soll, durchlaufen und verglichen und ggf. zur Ergebnismenge zugefügt werden. Das funzt, aber man stelle sich vor, es ist ein großer Bereich mit vielen Zellen wie in meiner Anwendung, und das muss man mehrfach machen. Dann kann man sich einen Kaffee holen.
Anzeige
AW: Funktion für Range aus Range "herausschneiden"
29.01.2018 08:42:09
Sulprobil
Tja, ich denke Rless macht was es soll, wird aber zu langsam sein.
Vielleicht musst Du einen ganz anderen Ansatz probieren.
Ich lese am Anfang meist alles in Variable und gebe erst das Endergebnis wieder in Zellen aus.
Viele Grüße,
Bernd P.
AW: Funktion für Range aus Range "herausschneiden"
29.01.2018 10:05:01
Sepp
Hallo Stefan,
hier ein Ansatz von http://dailydoseofexcel.com/archives/2007/08/17/two-new-range-functions-union-and-subtract/ etwas abgeändert, kannst ja mal die verschiedenen Versionen testen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub test()
NotIntersect(Range("A1:X100"), Range("B6:B70,D31:D89,F7:F37,G44:G82,I11:I40,I70:I94,K8:K40,K55:K59,L64:L94,M8:U14,P21:X24,N33:V39,Q47:S70,O78:W80,O91:W93")).Select
End Sub

Public Function NotIntersect(Target As Range, Exclude As Range) As Range
'original Code by http://dailydoseofexcel.com/archives/2007/08/17/two-new-range-functions-union-and-subtract/
Dim rng_Temp As Range, rng_New As Range, lngN As Integer, lngM As Integer
On Error Resume Next
If IsObject(Target) And IsObject(Exclude) Then
  If Not Target Is Nothing And Not Exclude Is Nothing Then
    If TypeOf Target Is Range And TypeOf Exclude Is Range Then
      If Not Intersect(Target, Exclude) Is Nothing Then
        For lngN = 1 To Target.Areas.Count
          Set rng_Temp = removeRange(Target.Areas(lngN), Exclude.Areas(1))
          For lngM = 2 To Exclude.Areas.Count
            Set rng_Temp = Intersect(rng_Temp, removeRange(Target.Areas(lngN), Exclude.Areas(lngM)))
          Next
          If rng_New Is Nothing Then Set rng_New = rng_Temp Else Set rng_New = Union(rng_New, rng_Temp)
        Next
        If Not rng_New Is Nothing Then Set NotIntersect = rng_New
      End If
    End If
  End If
End If
End Function

Private Function removeRange(Target As Range, Exclude As Range) As Range
Dim rng_1 As Range, rng_2 As Range, rng_New As Range, objSh As Worksheet

On Error Resume Next
If Target.Areas.Count > 1 Then Exit Function
If Exclude.Areas.Count > 1 Then Exit Function

If Intersect(Target, Exclude) Is Nothing Then
  Set removeRange = Target
  Exit Function
End If

Set rng_1 = Intersect(Target, Exclude)

Set objSh = Target.Parent
With objSh
  If rng_1.Row > Target.Row Then
    Set rng_New = .Range(Target.Rows(1), Target.Rows(rng_1.Row - Target.Row))
  End If
  If rng_1.Row + rng_1.Rows.Count < Target.Row + Target.Rows.Count Then
    Set rng_New = Union(rng_New, .Range(Target.Rows(rng_1.Row - Target.Row + _
      rng_1.Rows.Count + 1), Target.Rows(Target.Rows.Count)))
  End If
  If rng_1.Column > Target.Column Then
    Set rng_New = Union(rng_New, .Range(.Cells(rng_1.Row, Target.Column), _
      .Cells(rng_1.Row + rng_1.Rows.Count - 1, rng_1.Column - 1)))
  End If
  If rng_1.Column + rng_1.Columns.Count < Target.Column + Target.Columns.Count Then
    Set rng_New = Union(rng_New, .Range(.Cells(rng_1.Row, rng_1.Column + _
      rng_1.Columns.Count), .Cells(rng_1.Row + rng_1.Rows.Count - 1, _
      Target.Column + Target.Columns.Count - 1)))
  End If
End With

If Not rng_New Is Nothing Then Set removeRange = rng_New
End Function

Gruß Sepp

Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige