vba - para - macro actualizar todas las tablas dinamicas de una hoja

Diferencia entre dos rangos

Question

Puedo encontrar muchas preguntas y ejemplos sobre los métodos VBA ''Union'' e ''Intersect'', pero no puedo encontrar mucho sobre el método ''Set Difference''. ¿Existe esto (que no sea mediante el uso de combinaciones de unión e intersección) ?.

Estoy tratando de encontrar una manera simple de obtener todo el rango1 sin incluir el rango1 que se superpone al rango2 sin conocer el tamaño o la forma de ninguno de los rangos.

Cualquier ayuda sería muy apreciada.

EDITAR.

Intento de solución donde rng1 es la sección roja y rng2 es la sección azul (se han depurado para comprobar si son correctos):

rng = SetDifference(rng, highlightedColumns)
Function SetDifference(Rng1 As Range, Rng2 As Range) As Range
On Error Resume Next
If Application.Intersect(Rng1, Rng2).Address <> Rng2.Address Then
Exit Function
On Error GoTo 0
Dim aCell As Range
For Each aCell In Rng1
Dim Result As Range
If Application.Intersect(aCell, Rng2) Is Nothing Then
Set Result = Union(Result, aCell)
End If
Next aCell
Set SetDifference = Result
End If
End Function

Answer 1

^ Iterar por cada celda es muy lento para llamadas como

SetDifference (ActiveSheet.Cells, ActiveSheet.Range ("A1")) ''Todas las celdas excepto A1

Por lo tanto:

''(needed by the 2nd function)
Public Function Union(ByRef rng1 As Range, _
ByRef rng2 As Range) As Range
If rng1 Is Nothing Then
Set Union = rng2
Exit Function
End If
If rng2 Is Nothing Then
Set Union = rng1
Exit Function
End If
If Not rng1.Worksheet Is rng2.Worksheet Then
Exit Function
End If
Set Union = Application.Union(rng1, rng2)
End Function
Public Function Complement(ByRef rng1 As Range, _
ByRef rng2 As Range) As Range
Dim rngResult As Range
Dim rngResultCopy As Range
Dim rngIntersection As Range
Dim rngArea1 As Range
Dim rngArea2 As Range
Dim lngTop As Long
Dim lngLeft As Long
Dim lngRight As Long
Dim lngBottom As Long
If rng1 Is Nothing Then
Exit Function
End If
If rng2 Is Nothing Then
Set Complement = rng1
Exit Function
End If
If Not rng1.Worksheet Is rng2.Worksheet Then
Exit Function
End If
Set rngResult = rng1
For Each rngArea2 In rng2.Areas
If rngResult Is Nothing Then
Exit For
End If
Set rngResultCopy = rngResult
Set rngResult = Nothing
For Each rngArea1 In rngResultCopy.Areas
Set rngIntersection = Application.Intersect(rngArea1, rngArea2)
If rngIntersection Is Nothing Then
Set rngResult = Union(rngResult, rngArea1)
Else
lngTop = rngIntersection.Row - rngArea1.Row
lngLeft = rngIntersection.Column - rngArea1.Column
lngRight = rngArea1.Column + rngArea1.Columns.Count - rngIntersection.Column - rngIntersection.Columns.Count
lngBottom = rngArea1.Row + rngArea1.Rows.Count - rngIntersection.Row - rngIntersection.Rows.Count
If lngTop > 0 Then
Set rngResult = Union(rngResult, rngArea1.Resize(lngTop, rngArea1.Columns.Count))
End If
If lngLeft > 0 Then
Set rngResult = Union(rngResult, rngArea1.Resize(rngArea1.Rows.Count - lngTop - lngBottom, lngLeft).Offset(lngTop, 0))
End If
If lngRight > 0 Then
Set rngResult = Union(rngResult, rngArea1.Resize(rngArea1.Rows.Count - lngTop - lngBottom, lngRight).Offset(lngTop, rngArea1.Columns.Count - lngRight))
End If
If lngBottom > 0 Then
Set rngResult = Union(rngResult, rngArea1.Resize(lngBottom, rngArea1.Columns.Count).Offset(rngArea1.Rows.Count - lngBottom, 0))
End If
End If
Next rngArea1
Next rngArea2
Set Complement = rngResult
End Function

Answer 2

Pruebe esta función después de haberla mejorado un poco:

Function SetDifference(Rng1 As Range, Rng2 As Range) As Range
On Error Resume Next
If Intersect(Rng1, Rng2) Is Nothing Then
''if there is no common area then we will set both areas as result
Set SetDifference = Union(Rng1, Rng2)
''alternatively
''set SetDifference = Nothing
Exit Function
End If
On Error GoTo 0
Dim aCell As Range
For Each aCell In Rng1
Dim Result As Range
If Application.Intersect(aCell, Rng2) Is Nothing Then
If Result Is Nothing Then
Set Result = aCell
Else
Set Result = Union(Result, aCell)
End If
End If
Next aCell
Set SetDifference = Result
End Function

Recuerde llamarlo así:

Set Rng = SetDifference(Rng, highlightedColumns)

Answer 3

Cuando los rangos tienen ambas áreas, necesitará un enfoque diferente. No xlCellTypeConstants la idea central de este ejemplo y no recuerdo dónde encontré esta idea (usando xlCellTypeConstants ). Lo adapté para hacerlo funcionar para rangos con áreas:

'' Range operator that was missing
Public Function rngDifference(rn1 As Range, rn2 As Range) As Range
Dim rnAreaIntersect As Range, varFormulas As Variant
Dim rnAreaS As Range, rnAreaR As Range, rnAreaDiff As Range
Dim rnAreaModified As Range, rnOut As Range
On Error Resume Next
Set rngDifference = Nothing
If rn1 Is Nothing Then Exit Function
If rn2 Is Nothing Then Set rngDifference = rn1: Exit Function
Set rnOut = Nothing
For Each rnAreaS In rn1.Areas
Set rnAreaModified = rnAreaS
For Each rnAreaR In rn2.Areas
Set rnAreaIntersect = Intersect(rnAreaModified, rnAreaR)
If rnAreaIntersect Is Nothing Then
Set rnAreaDiff = rnAreaModified
Else '' there is interesection
''save
varFormulas = rnAreaS.Formula
rnAreaS.Value = 0: rnAreaIntersect.ClearContents
If rnAreaS.Cells.Count = 1 Then
Set rnAreaDiff = Intersect(rnAreaS.SpecialCells(xlCellTypeConstants), rnAreaS)
Else
Set rnAreaDiff = rnAreaS.SpecialCells(xlCellTypeConstants)
End If
''restore
rnAreaS.Formula = varFormulas
End If
If Not (rnAreaModified Is Nothing) Then
Set rnAreaModified = Intersect(rnAreaModified, rnAreaDiff)
End If
Next
If Not (rnAreaModified Is Nothing) Then
If rnOut Is Nothing Then
Set rnOut = rnAreaModified
Else
Set rnOut = Union(rnOut, rnAreaModified)
End If
End If
Next
Set rngDifference = rnOut
End Function

Espero que esto ayude