Differenz, Komplement von Bereichen
13.08.2012 16:50:40
Bereichen
Hi Peter,
probier mal den fiolgenden Code. Die Fkt. DiffRange() funzt auch,
dauert aber etwas länger:
Option Explicit
Sub RngRest()
Dim rngA As Range, rngB As Range, rngC As Range
Set rngA = Range("1:66")
Set rngB = Range("1:1,20:21")
MsgBox Intersect(rngA, ComplMulti(rngB)).Address
' MsgBox DiffRange(rngA, rngB).Address
End Sub
Function ComplMulti(rngS As Range) As Range ' Komplement einer Mehrfachmarkierung
' www.online-excel.de/fom/fo_read.php?f=1&bzh=43557&h=43489#a123x
Dim rngX As Range, rngC As Range
For Each rngX In rngS.Areas
Set rngC = ComplRect(rngX)
If Not rngC Is Nothing Then
If ComplMulti Is Nothing Then
Set ComplMulti = rngC
Else
Set ComplMulti = Intersect(ComplMulti, rngC)
End If
End If
Next rngX
End Function
' Komplement eines Rechteck-Bereichs zurück
Function ComplRect(rngA As Range) As Range
Dim zv As Long, zb As Long, sv As Long, sb As Long, rngT As Range
zv = rngA.Row: zb = zv + rngA.Rows.Count - 1
sv = rngA.Column: sb = sv + rngA.Columns.Count - 1
If zv > 1 Then Set rngT = Range(Rows(1), Rows(zv - 1))
If zb 1 Then
If rngT Is Nothing Then
Set rngT = Range(Cells(zv, 1), Cells(zb, sv - 1))
Else
Set rngT = Union(rngT, Range(Cells(zv, 1), Cells(zb, sv - 1)))
End If
End If
If sb
Im Code stehen zwei Links zu online-excel , da kannst du ja auch noch mal stöbern...
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich