Excel e gli applicativi Microsoft Office Sottrazione di ranges

LoginRegistrati
Stai vedendo 16 articoli - dal 1 a 16 (di 16 totali)
  • Autore
    Articoli
  • #6234 Risposta

    vecchio frac
    Senior Moderator
      171 pts

      Ho visto in qualche ultima discussione l'utilizzo di Union.

      Tempo fa (once upon a time) avevo la necessità di sottrarre un range da un altro.

      Cercando un po' sono infine approdato a Stackoverflow che mi ha dato lo spunto per il codice che propongo, da utilizzare in un modulo nuovo.

      Option Explicit
      
      'see discussion here: https://stackoverflow.com/questions/21580795/subtracting-ranges-in-vba-excel
      
      Public Function SubtractRanges(rFirst As Range, rSecond As Range) As Range
      '
      ' Returns a range of cells that are part of rFirst, but not part of rSecond
      ' (as in set subtraction)
      '
      ' This function handles big input ranges really well!
      '
      ' The reason for having a separate recursive function is
      ' handling multi-area rFirst range
      '
          Dim rInter As Range
          Dim rReturn As Range
          Dim rArea As Range
          Dim mrBuild  As Range
      
          Set rInter = Intersect(rFirst, rSecond)
          Set mrBuild = Nothing
      
          If rInter Is Nothing Then 'no overlap
              Set rReturn = rFirst
          ElseIf rInter.Address = rFirst.Address Then 'total overlap
              Set rReturn = Nothing
          Else 'partial overlap
              For Each rArea In rFirst.Areas
                  Set mrBuild = BuildRange(rArea, rInter) 'recursive
              Next rArea
              Set rReturn = mrBuild
          End If
      
          Set SubtractRanges = rReturn
      End Function
      
      
      Private Function BuildRange(rArea As Range, rInter As Range, _
      Optional mrBuild As Range = Nothing) As Range
      '
      ' Recursive function for SubtractRanges()
      ' Don't use separately.
      ' Subtracts rInter from rArea and adds the result to mrBuild
      '
          Dim rLeft As Range, rRight As Range
          Dim rTop As Range, rBottom As Range
          Dim rInterSub As Range
          Dim GoByColumns As Boolean
      
          Set rInterSub = Intersect(rArea, rInter)
          If rInterSub Is Nothing Then 'no overlap
              If mrBuild Is Nothing Then
                  Set mrBuild = rArea
              Else
                  Set mrBuild = Union(mrBuild, rArea)
              End If
          ElseIf Not rInterSub.Address = rArea.Address Then 'some overlap
              If Not rArea.Cells.CountLarge = 1 Then 'just in case there is only one cell for some impossible reason
      
                  ' Decide whether to go by columns or by rows
                  ' (helps when subtracting whole rows/columns)
                  If Not rInterSub.Columns.Count = rArea.Columns.Count And _
                  ((Not rInterSub.Cells.CountLarge = 1 And _
                  (rInterSub.Rows.Count > rInterSub.Columns.Count _
                  And rArea.Columns.Count > 1) Or (rInterSub.Rows.Count = 1 _
                  And Not rArea.Columns.Count = 1)) Or _
                  (rInterSub.Cells.CountLarge = 1 _
                  And rArea.Columns.Count > rArea.Rows.Count)) Then
                          GoByColumns = True
                  Else
                          GoByColumns = False
                  End If
      
                  If Not GoByColumns Then
                      Set rTop = rArea.Resize(rArea.Rows.Count \ 2) 'split the range top to bottom
                      Set rBottom = rArea.Resize(rArea.Rows.Count - rTop.Rows.Count).Offset(rTop.Rows.Count)
                      Set mrBuild = BuildRange(rTop, rInterSub, mrBuild) 'rerun it
                      Set mrBuild = BuildRange(rBottom, rInterSub, mrBuild)
                  Else
                      Set rLeft = rArea.Resize(, rArea.Columns.Count \ 2) 'split the range left to right
                      Set rRight = rArea.Resize(, rArea.Columns.Count - rLeft.Columns.Count).Offset(, rLeft.Columns.Count)
                      Set mrBuild = BuildRange(rLeft, rInterSub, mrBuild) 'rerun it
                      Set mrBuild = BuildRange(rRight, rInterSub, mrBuild)
                  End If
              End If
          End If
      
          Set BuildRange = mrBuild
      End Function
      
      

      Un piccolo codice di esempio per testare quanto sopra lo propongo qui:

      Sub test()
      Dim r1 As Range, r2 As Range
      Dim i As Integer
      
          Set r1 = Range("a1..c11")
          Set r2 = Range("b3,b6..c8")
          
          For i = 1 To 6
              Cells.Clear
              If i Mod 2 = 1 Then
                  SubtractRanges(r1, r2).Interior.ColorIndex = 33
              Else
                  r2.Interior.ColorIndex = 33
              End If
              Application.Wait (Now + TimeValue("0:00:01"))
          Next
          MsgBox "Done"
      End Sub
      #6311 Risposta
      patel
      patel
      Moderatore
        43 pts

        Ciao VF, non mi funziona, i range devono essere della stessa dimensione immagino, perché il ciclo for arriva fino a 6 ? io ho provato questa sub

        Sub differenza_ranges()
        Dim r1 As Range, r2 As Range
        Dim i As Integer
            Set r1 = Range("a1:d6")
            Set r2 = Range("F1:I6")
            For i = 1 To 6
                Cells.Clear
                If i Mod 2 = 1 Then
                    SubtractRanges(r1, r2).Interior.ColorIndex = 33
                Else
                    r2.Interior.ColorIndex = 33
                End If
                Application.Wait (Now + TimeValue("0:00:01"))
            Next
            MsgBox "Done"
        End Sub
        
        #6325 Risposta

        vecchio frac
        Senior Moderator
          171 pts

          Perchè non ti funziona? ho provato il tuo codice e funziona bene.

          Fa quel che gli dici di fare: sottrae range non sovrapposti 🙂

          Definisci in modo diverso i due range r1 e r2 in modo che si sovrappongano e vedi cosa succede:

          Set r1 = Range("a1:i6")
          Set r2 = Range("d1:f6")

          #6366 Risposta
          patel
          patel
          Moderatore
            43 pts

            provato, ma si colorano soltanto si azzurro, per il resto non accade niente, allego file

            Allegati:
            You must be logged in to view attached files.
            #6368 Risposta
            Marius44
            Marius44
            Moderatore
              36 pts

              Ciao a tutti

              @patel

              nel tuo codice hai 'commentato'  Cells.Clear

              Decommentalo, altrimenti le celle rimangono tutte colorate e non si "vede" l'alternanza dei colori. Se vuoi puoi limitare la cancellazione solo ad una parte -per es. Range("A1:C10").Clear- e vedrai il ... movimento solo in queste celle.

              Sempre se ho capito gli insegnamenti di VF

              Ciao,

              Mario

              #6369 Risposta

              vecchio frac
              Senior Moderator
                171 pts

                Oppure metti valori diversi alla proprietà ColorIndex.

                #6371 Risposta
                patel
                patel
                Moderatore
                  43 pts

                  devo aver male interpretato la parola sottrazione, credevo tu intendessi fare la differenza dei valori di 2 matrici

                  #6372 Risposta
                  Marius44
                  Marius44
                  Moderatore
                    36 pts

                    Salve a tutti

                    Allego il file sul quale ho lavorato ed in cui ho aggiunto una cosa che mi piacerebbe fare ma non riesco.

                    Mi sta bene la "sottrazione" di range (anche se in un primo momento ero allineato al pensiero di patel) però mi piacerebbe che la zona di sovrapposizione venisse colorata con altro colore per evidenziarla.

                    Cliccate sul pulsante prova 2

                    Ciao,

                    Mario

                    Allegati:
                    You must be logged in to view attached files.
                    #6374 Risposta

                    vecchio frac
                    Senior Moderator
                      171 pts

                      patel wrote:devo aver male interpretato la parola sottrazione, credevo tu intendessi fare la differenza dei valori di 2 matrici

                      Intendevo proprio il contrario di Application.Union che invece unisce più (riferimenti a un) range in un (riferimento a un) range unico.

                      In certi lavori passati mi è stata utile la funzione opposta dell'unione, cioè la sottrazione, per ottenere un range cui sono stati portati via dei subrange.

                      #6375 Risposta

                      vecchio frac
                      Senior Moderator
                        171 pts

                        Marius44 wrote:la zona di sovrapposizione

                        Se non ho capito male puoi assegnare a una variabile Range il risultato di un SubtractRanges:

                        Set r0 = SubtractRanges(r1, r2)

                        r0 dovrebbe contenere il riferimento al range derivante dalla zona di "sovrapposizione".

                        #6376 Risposta

                        vecchio frac
                        Senior Moderator
                          171 pts

                          Ah no, ho capito vedendo il tuo file.

                          La funzione di "overlap" esiste e si chiama Intersect:

                          Set r0 = Intersect(r1, r2)
                          r0.Interior.ColorIndex = 35
                          
                          #6377 Risposta
                          Marius44
                          Marius44
                          Moderatore
                            36 pts

                            Perfetto!!!!!

                             

                            Ciao,

                            Mario

                            #6410 Risposta
                            scossa
                            scossa
                            Partecipante
                              2 pts

                              Ciao vecchio frac,

                              una soluzione più semplice viene dal mitico Roberto Mensa (r)

                              https://sites.google.com/site/e90e50/vba/funzionitascabili/unionb-ibridotraunioneintersect

                              che propongo con la banalissima modifica per escludere la parte del secondo range non inclusa nel primo

                              Public Function DisUnion( _
                                  Rng1 As Excel.Range, _
                                  Rng2 As Excel.Range) As Excel.Range
                                  
                              'E90E50
                              'https://sites.google.com/site/e90e50/vba/funzionitascabili/unionb-ibridotraunioneintersect
                              'by scossa: variante che esclude le celle del secondo range non in comune col primo range, cioè
                              'restituisce le celle del primo range escludendo la parte in comune col secondo
                              'vedi https://www.excelvba.it/forumexcel/forums/discussione/sottrazione-di-ranges/
                                  
                              	Dim Cella As Excel.Range
                              	Dim RngInt As Excel.Range
                              	Dim b As Boolean
                              
                              	Set RngInt = Application.Intersect(Rng1, Rng2)
                              
                              	If RngInt Is Nothing Then
                              			Set DisUnion = Union(Rng1, Rng2)
                              			Exit Function
                              	End If
                              
                              	If Rng1.Address = Rng2.Address Then Exit Function
                              
                              	For Each Cella In Union(Rng1, Rng2)
                              			If Application.Intersect(RngInt, Cella) Is Nothing Then
                              					If b = False Then
                              							Set DisUnion = Cella
                              							b = True
                              					Else
                              							Set DisUnion = Union(DisUnion, Cella)
                              					End If
                              			End If
                              	Next
                              
                              	'by scossa: modifica per escludere le celle del secondo range
                              	Set DisUnion = Intersect(DisUnion, Rng1)
                              	'fine modifica
                              
                              	End Function

                              Questo il codice per il test:

                              Sub TestVF2()
                              	Dim r1 As Range, r2 As Range
                              
                              	Set r1 = Range("a1..c11")
                              	Set r2 = Range("b3,b6..d8")
                              	
                              	SubtractRanges(r1, r2).Interior.ColorIndex = 33
                              	
                              	Set r1 = Range("g1..i11")
                              	Set r2 = Range("h3,h6..j8")
                              	
                              	DisUnion(r1, r2).Interior.ColorIndex = 45
                              
                              End Sub

                               

                              #6414 Risposta

                              vecchio frac
                              Senior Moderator
                                171 pts

                                Grande il solito nick r ... questo codice mi piace di più!!

                                grazie scossa sempre preciso!

                                #6417 Risposta
                                Marius44
                                Marius44
                                Moderatore
                                  36 pts

                                  Ciao a tutti

                                  mi rivolgo in particolare ai "Mostri Sacri"

                                  Ho notato che alla fine delle Sub non avete posto a Nothing quanto in precedenza Set tato.

                                  E' una dimenticanza (ma da parte degli estensori, non credo proprio) oppure cosa?

                                  Ciao,

                                  Mario

                                  #6426 Risposta

                                  vecchio frac
                                  Senior Moderator
                                    171 pts

                                    Sono oggetti Range quindi definiti da Excel e non restano appesi in memoria quando si esce da Excel, che annienta tutto. In realtà il garbage collector dovrebbe annientare qualsiasi oggetto al termine dell'esecuzione del programma principale, ma non sempre succede soprattutto quando crei ad esempio un'istanza di Word in Excel e magari il programma si interrompe per un errore; nemmeno se esci da Excel l'oggetto Word viene distrutto e quindi resta appeso in memoria, creando talvolta seri problemi.

                                    Regola generale: meglio sempre distruggere esplicitamente gli oggetti che sono creati con CreateObject; gli altri, per definizione, no perchè vivono dentro l'applicativo principale.

                                  LoginRegistrati
                                  Stai vedendo 16 articoli - dal 1 a 16 (di 16 totali)
                                  Rispondi a: Sottrazione di ranges
                                  Gli allegati sono permessi solo ad utenti REGISTRATI
                                  Le tue informazioni:



                                  vecchio frac - 2750 risposte

                                  patel
                                  patel - 1089 risposte

                                  albatros54
                                  albatros54 - 1062 risposte

                                  Marius44
                                  Marius44 - 1000 risposte

                                  Luca73
                                  Luca73 - 798 risposte