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