Bordi esterni in una selezione qualsiasi

[recalcatiiti]

Buongiorno a tutti,

ho provato a cercare nel forum, ma non ho trovato un topic simili, mi scuso se in realtà esiste.

Ho necessità di creare un bordo esterno a selezioni non rettangolari. Supponiamo, come nelle immagini allegate, che alcune celle siano contrassegnate da un asterisco. La macro, una volta selezionata un'area del foglio, dovrebbe riconoscere tutte le celle contenenti asterischi e se alcuni sono adiacenti riconoscerli come un'unica selezione e bordarne solo l'esterno.

Prima


Dopo


Riconosco che non sia un algoritmo banale, spero soltanto che qualcuno ci abbia già pensato e che possa riproporlo qui.
Spero che il miracoloso Anthony47 (che saluto) mi possa aiutare.

Grazie in ogni caso, un caro saluto.

Stefano

[recalcatiiti]

[EDIT] Mi sono reso conto di aver sbagliato l'esposizione del problema (oltre che alle immagini). Mi scuso.

Prima


La selezione effettuata


Dopo


In pratica l'algoritmo andrebbe applicato solo alle celle esterne delle selezione. E qualora ci fosse un asterisco su una delle celle esterne della selezione, si estenda anche all'interno nel modo indicato dalle immagini bordando le celle contenenti asterischi adiacenti.

Informazioni aggiuntive:
- la selezione deve avere un estensione qualunque.
- la disposizione degli asterischi è pressoché casuale.

Mi rendo conto che sia molto complesso.

Vi ringrazio per qualunque contributo.

[recalcatiiti]

Un esempio più esaustivo.

La selezione effettuata


Dopo

[Marius44]

Ciao
Hai detto bene: non è un algoritmo semplice. Ti do solo un accenno di come si potrebbe fare con questo codice

Codice: Seleziona tutto

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range, selez As String
Dim slx, riga_i As Long, riga_u As Long, col_i As Long, col_u As Long
Dim i As Long, j As Long
If Target.Count = 1 Then Exit Sub
selez = Target.Address
slx = Split(selez, "$")
riga_i = Val(slx(2))
riga_u = Val(slx(4))
col_i = ActiveSheet.Range(UCase(slx(1)) & "1").Column
col_u = ActiveSheet.Range(UCase(slx(3)) & "1").Column
Stop
For i = riga_i To riga_u
  For j = col_i To col_u
    If Cells(i, j).Row = Val(slx(2)) And Cells(i, j) = "" Then
      Cells(i, j).Borders(xlEdgeTop).LineStyle = xlContinuous
    ElseIf Cells(i, j).Row = Val(slx(2)) And Cells(i, j) = "*" Then
      Cells(i, j).Borders(xlEdgeLeft).LineStyle = xlContinuous
      Cells(i, j).Borders(xlEdgeRight).LineStyle = xlContinuous
    End If
  Next j
Next i
End Sub


Ovviamente è da completare e limare per le tue esigenze.
Ciao,
Mario

[Anthony47]

Ho usato un approccio diverso da quanto sviluppato da Mario, sopra, che ha portato a questo codice:

Codice: Seleziona tutto

Dim MLC As Long, MRC As Long, TRow As Long, BRow As Long
Dim crArr, colArr() As Long
Const BCol As Long = 200    'Il colore
Const BTick As Long = 3     'Lo spessore



Sub SetBorders2()
Dim I As Long, J As Long, kK As Long, ckCnt As Long
'
MLC = Selection.Cells(1, 1).Column
MRC = MLC + Selection.Columns.Count - 1
TRow = Selection.Cells(1, 1).Row
BRow = TRow + Selection.Rows.Count - 1
crArr = Range(Cells(1, 1), Cells(BRow, MRC)).Value
ReDim colArr(1 To UBound(crArr) + 1, 1 To UBound(crArr, 2) + 1)
'
For kK = 1 To 100
    ckCnt = 0
    For I = TRow To UBound(crArr)
        For J = MLC To UBound(crArr, 2)
            If crArr(I, J) <> "" And colArr(I, J) = 0 Then
                If I = TRow Or I = BRow Or J = MLC Or J = MRC Then
                    colArr(I, J) = 1
                    ckCnt = ckCnt + 1
'                    Cells(I, J).Interior.Color = RGB(200, 200, 255)
                Else
                    If ckIt(I, J) Then
                        colArr(I, J) = 1
                        ckCnt = ckCnt + 1
'                        Cells(I, J).Interior.Color = RGB(200, 200, 255)
                    End If
                End If
            End If
DoEvents
        Next J
    Next I
    If ckCnt = 0 Then Exit For
Next kK
'
Selection.Borders.LineStyle = xlNone
For I = TRow To UBound(crArr)
    For J = MLC To UBound(crArr, 2)
        If J = MLC And colArr(I, J) = 0 Then Call SetBorder(I, J, 7)                'Left
        If J = MRC And colArr(I, J) = 0 Then Call SetBorder(I, J, 10)               'right
        If I = TRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 8)               'Top
        If I = BRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 9)               'Bottom
        If I = TRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 8)               'Top
        If colArr(I, J) = 1 And colArr(I, J - 1) = 0 And J > MLC Then Call SetBorder(I, J, 7) 'Left
        If colArr(I, J) = 1 And colArr(I, J + 1) = 0 And J < MRC Then Call SetBorder(I, J, 10) 'Right
        If colArr(I, J) = 1 And colArr(I + 1, J) = 0 And I < BRow Then Call SetBorder(I, J, 9) 'Bottom
        If colArr(I, J) = 1 And colArr(I - 1, J) = 0 And I > TRow Then Call SetBorder(I, J, 8) 'Top
    Next J
Next I
End Sub


Function ckIt(ByVal IR As Long, ByVal IC As Long) As Boolean
    If colArr(IR, IC) > 0 Then Exit Function
    If IC = UBound(crArr, 2) Then Exit Function
    If IR = UBound(crArr) Then Exit Function
    If colArr(IR - 1, IC) + colArr(IR + 1, IC) + colArr(IR, IC - 1) + colArr(IR, IC + 1) > 0 Then
        ckIt = True
    End If
End Function


Sub SetBorder(CI As Long, CJ As Long, bNum As Long)
'7=left, 8=top, 9=bottom, 10=right
'
With Cells(CI, CJ).Borders(bNum)
    .LineStyle = xlContinuous
    .Color = BCol
    .Weight = BTick
End With
End Sub


Va copiato in un modulo standa inizialmente vuoto.
Poi si seleziona l'area da esaminare e si lancia la Sub SetBorders

Per semplicita' la selezione non deve includere né riga 1 né colonna 1

Il risultato sara' come da immagine:

(area selezionata: E3:X23

Con il dubbio della cella Q3, evidenziata in arancione; infatti non mi e' chiaro se R3 va considerata contigua con Q4

[recalcatiiti]

Buongiorno a tutti,

Mario ti ringrazio per l'incipit, Anthony però mi porge su un piatto d'argento la soluzione al mio problema.

Anthony ti ringrazio moltissimo è perfetta! Quel dubbio nel caso della cella Q3 lo posso ovviare senza modificare la tua macro; quella cella non dovrebbe essere bordata ma gli esempi da me proposti non erano del tutto esaustivi. Che dire, grazie e a presto.

Stefano

[Anthony47]

In realta' Q3 non e' bordata, ma lo appare perche' la bordatura e' applicata alle tre celle che partono da P3 e alla cella R3

Ho dimenticato di dire che colore e spessore del bordo si impostano variando le costanti BCol e BTick, in testa

[recalcatiiti]

Chiaro, è comunque una situazione ovviabile.

Vorrei porti una domanda fatidica: è possibile evitare che la macro sovrascriva eventuali bordi già presenti nelle celle della selezione?

Ti ringrazio.

Stefano

[recalcatiiti]

Esempio:

La selezione effettuata


Dopo

[recalcatiiti]

Credo di aver risolto,

bastava commentare:

Codice: Seleziona tutto

Selection.Borders.LineStyle = xlNone

Vi faccio sapere se basta.

Grazie a tutti

[recalcatiiti]

Ora si pone un altro problema. Avrei bisogno di preservare tutta la formattazione interna al bordo che la macro produce e pulire completamente da ogni altra formattazione ciò che sta nelle riseghe del bordo appena formato.

Esempio:

Prima


La selezione effettuata


Dopo


Spero siano abbastanza chiari questi esempi.

Vi ringrazio molto ragazzi!

Stefano

[Anthony47]

Cos'è, il quesito della Susi, dove per vincere bisogna scoprire il piccolo particolare cambiato?

[recalcatiiti]

Hai ragione Anthony mi scuso.
Dimmi in che modo posso essere più chiaro, vuoi che ti propongo un altro esempio?

[recalcatiiti]

Per "riseghe" intendo tulle le aree gialle indicate nell'immagine che segue (ovvero ciò che faceva parte della selezione ma che è esterno al bordo appena creato)



In effetti se guardi nell'ultima immagine del mio messaggio precedente, noterai che le "riseghe" sono prive di formattazione, mentre ciò che è dentro al bordo ha la stessa formattazione di prima.

Ti ringrazio per qualunque spunto, anche sull'infattibilità di tale richiesta

(in privato se ti interessa posso dirti a che serve questo "aggeggio")

[Anthony47]

Se ho capito bene dobbiamo cancellare contenuto e colore alle celle "escluse". Per questo e' necessario aggiungere un blocco ad hoc alla Sub SetBorders attuale.
Il nuovo codice completo:

Codice: Seleziona tutto

Dim MLC As Long, MRC As Long, TRow As Long, BRow As Long
Dim crArr, colArr() As Long
Const BCol As Long = 200    'Il colore
Const BTick As Long = 3     'Lo spessore



Sub SetBorders()
Dim I As Long, J As Long, kK As Long, ckCnt As Long

MLC = Selection.Cells(1, 1).Column
MRC = MLC + Selection.Columns.Count - 1
TRow = Selection.Cells(1, 1).Row
BRow = TRow + Selection.Rows.Count - 1
crArr = Range(Cells(1, 1), Cells(BRow, MRC)).Value
ReDim colArr(1 To UBound(crArr) + 1, 1 To UBound(crArr, 2) + 1)
'
For kK = 1 To 100
    ckCnt = 0
    For I = TRow To UBound(crArr)
        For J = MLC To UBound(crArr, 2)
            If crArr(I, J) <> "" And colArr(I, J) = 0 Then
                If I = TRow Or I = BRow Or J = MLC Or J = MRC Then
                    colArr(I, J) = 1
                    ckCnt = ckCnt + 1
'                    Cells(I, J).Interior.Color = RGB(200, 200, 255)
                Else
                    If ckIt(I, J) Then
                        colArr(I, J) = 1
                        ckCnt = ckCnt + 1
'                        Cells(I, J).Interior.Color = RGB(200, 200, 255)
                    End If
                End If
            End If
DoEvents
        Next J
    Next I
    If ckCnt = 0 Then Exit For
Next kK

''Selection.Borders.LineStyle = xlNone

For I = TRow To UBound(crArr)
    For J = MLC To UBound(crArr, 2)
        If J = MLC And colArr(I, J) = 0 Then Call SetBorder(I, J, 7)                'Left
        If J = MRC And colArr(I, J) = 0 Then Call SetBorder(I, J, 10)               'right
        If I = TRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 8)               'Top
        If I = BRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 9)               'Bottom
        If I = TRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 8)               'Top
        If colArr(I, J) = 1 And colArr(I, J - 1) = 0 And J > MLC Then Call SetBorder(I, J, 7) 'Left
        If colArr(I, J) = 1 And colArr(I, J + 1) = 0 And J < MRC Then Call SetBorder(I, J, 10) 'Right
        If colArr(I, J) = 1 And colArr(I + 1, J) = 0 And I < BRow Then Call SetBorder(I, J, 9) 'Bottom
        If colArr(I, J) = 1 And colArr(I - 1, J) = 0 And I > TRow Then Call SetBorder(I, J, 8) 'Top
    Next J
Next I
'
Dim TArr() As Long, LArr() As Long
ReDim TArr(1 To UBound(crArr, 2))
ReDim LArr(1 To UBound(crArr))
'7=left, 8=top, 9=bottom, 10=right
For I = TRow To UBound(crArr)
    For J = MLC To UBound(crArr, 2)
        If Cells(I, J).Borders(8).LineStyle <> xlNone Then
            If TArr(J) <> 0 Then TArr(J) = 0 Else TArr(J) = I
        End If
        If Cells(I, J).Borders(7).LineStyle <> xlNone Then
            If LArr(I) <> 0 Then LArr(I) = 0 Else LArr(I) = I
        End If
Debug.Print Cells(I, J).Address(0, 0), "Left="; LArr(I), "Top="; TArr(J)
        If TArr(J) = 0 And crArr(I, J) <> "" Then
            Cells(I, J).Interior.Color = xlNone
            Cells(I, J).ClearContents
        End If
        If LArr(I) = 0 And crArr(I, J) <> "" Then
            Cells(I, J).Interior.Color = xlNone
            Cells(I, J).ClearContents
        End If
    Next J
Next I
End Sub


Function ckIt(ByVal IR As Long, ByVal IC As Long) As Boolean
    If colArr(IR, IC) > 0 Then Exit Function
    If IC = UBound(crArr, 2) Then Exit Function
    If IR = UBound(crArr) Then Exit Function
    If colArr(IR - 1, IC) + colArr(IR + 1, IC) + colArr(IR, IC - 1) + colArr(IR, IC + 1) > 0 Then
        ckIt = True
    End If
End Function


Sub SetBorder(CI As Long, CJ As Long, bNum As Long)
'7=left, 8=top, 9=bottom, 10=right
'
With Cells(CI, CJ).Borders(bNum)
   
    .LineStyle = xlContinuous
    .Color = BCol
    .Weight = BTick
End With
End Sub


Ho usato XL un po' per tutto, ma sono curioso di conoscere la destinazione di questo sviluppo

[recalcatiiti]

Ciao Anthony,

grazie per l'implementazione. Sarebbe necessario però che tolga anche eventuali bordi, diversi da quello spesso esterno che inserisce la macro.

La parte che si occupa di togliere il riempimento e il contenuto è credo questa:

Codice: Seleziona tutto

        If TArr(J) = 0 And crArr(I, J) <> "" Then
            Cells(I, J).Interior.Color = xlNone
            Cells(I, J).ClearContents
        End If
        If LArr(I) = 0 And crArr(I, J) <> "" Then
            Cells(I, J).Interior.Color = xlNone
            Cells(I, J).ClearContents
        End If

Ma non credo basti aggiungere una cosa come:

Codice: Seleziona tutto

Cells(I, J).Borders.LineStyle = xlNone

per togliere eventuali bordi non voluti. Credo che in questo modo tolga anche i bordi spessi appena creati.

Ti scrivo volentieri in MP e ti spiego tutto. grazie!

[recalcatiiti]

Esempio considerando di selezionare tutta la tabella con i bordi sottili.

Selezione effettuata:



Dopo


nelle riseghe viene eliminato il testo, il riempimento e eventuali bordi sottili.

[Anthony47]

L'uso dei bordi mette in crisi l'algoritmo utilizzato; devo quindi lavorare sul colore, assumendo che il Color dei bordi aggiunti sia diverso da quello dei bordi piccoli.
Non e' un grande vincolo, perche' se vuoi anche i bordi aggiunti in Nero ti bastera' impostare Const BCol As Long = 2 e sara' praticamente nero ma diverso da nero (che ha il codice 0).
A questo punto bisogna modificare la parte conclusiva di Sub SetBorders che avevamo appena aggiunto e aggiungere (nello stesso modulo vba) una nuova Sub Deformat

Il codice COMPLESSIVO:

Codice: Seleziona tutto

Dim MLC As Long, MRC As Long, TRow As Long, BRow As Long
Dim crArr, colArr() As Long
Const BCol As Long = 200    'Il colore
Const BTick As Long = 3     'Lo spessore



Sub SetBorders()
Dim I As Long, J As Long, kK As Long, ckCnt As Long

MLC = Selection.Cells(1, 1).Column
MRC = MLC + Selection.Columns.Count - 1
TRow = Selection.Cells(1, 1).Row
BRow = TRow + Selection.Rows.Count - 1
crArr = Range(Cells(1, 1), Cells(BRow, MRC)).Value
ReDim colArr(1 To UBound(crArr) + 1, 1 To UBound(crArr, 2) + 1)
'
For kK = 1 To 100
    ckCnt = 0
    For I = TRow To UBound(crArr)
        For J = MLC To UBound(crArr, 2)
            If crArr(I, J) <> "" And colArr(I, J) = 0 Then
                If I = TRow Or I = BRow Or J = MLC Or J = MRC Then
                    colArr(I, J) = 1
                    ckCnt = ckCnt + 1
'                    Cells(I, J).Interior.Color = RGB(200, 200, 255)
                Else
                    If ckIt(I, J) Then
                        colArr(I, J) = 1
                        ckCnt = ckCnt + 1
'                        Cells(I, J).Interior.Color = RGB(200, 200, 255)
                    End If
                End If
            End If
DoEvents
        Next J
    Next I
    If ckCnt = 0 Then Exit For
Next kK

''Selection.Borders.LineStyle = xlNone

For I = TRow To UBound(crArr)
    For J = MLC To UBound(crArr, 2)
        If J = MLC And colArr(I, J) = 0 Then Call SetBorder(I, J, 7)                'Left
        If J = MRC And colArr(I, J) = 0 Then Call SetBorder(I, J, 10)               'right
        If I = TRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 8)               'Top
        If I = BRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 9)               'Bottom
        If I = TRow And colArr(I, J) = 0 Then Call SetBorder(I, J, 8)               'Top
        If colArr(I, J) = 1 And colArr(I, J - 1) = 0 And J > MLC Then Call SetBorder(I, J, 7) 'Left
        If colArr(I, J) = 1 And colArr(I, J + 1) = 0 And J < MRC Then Call SetBorder(I, J, 10) 'Right
        If colArr(I, J) = 1 And colArr(I + 1, J) = 0 And I < BRow Then Call SetBorder(I, J, 9) 'Bottom
        If colArr(I, J) = 1 And colArr(I - 1, J) = 0 And I > TRow Then Call SetBorder(I, J, 8) 'Top
    Next J
Next I
'
'Exit Sub

Dim TArr() As Long, LArr() As Long, K As Long
ReDim TArr(1 To UBound(crArr, 2))
ReDim LArr(1 To UBound(crArr))
'7=left, 8=top, 9=bottom, 10=right
For I = TRow To UBound(crArr)
    For J = MLC To UBound(crArr, 2)
        If Cells(I, J).Borders(8).Color = BCol Then
            If TArr(J) <> 0 Then TArr(J) = 0 Else TArr(J) = I
        End If
        If Cells(I, J).Borders(7).Color = BCol Then
            If LArr(I) <> 0 Then LArr(I) = 0 Else LArr(I) = I
        End If
        Debug.Print Cells(I, J).Address(0, 0), "Left="; LArr(I), "Top="; TArr(J)
        If TArr(J) = 0 And crArr(I, J) <> "" Then
            Call Deformat(I, J)
        End If
        If LArr(I) = 0 And crArr(I, J) <> "" Then
            Call Deformat(I, J)
        End If
    Next J
Next I
'

End Sub



Function ckIt(ByVal IR As Long, ByVal IC As Long) As Boolean
    If colArr(IR, IC) > 0 Then Exit Function
    If IC = UBound(crArr, 2) Then Exit Function
    If IR = UBound(crArr) Then Exit Function
    If colArr(IR - 1, IC) + colArr(IR + 1, IC) + colArr(IR, IC - 1) + colArr(IR, IC + 1) > 0 Then
        ckIt = True
    End If
End Function


Sub SetBorder(CI As Long, CJ As Long, bNum As Long)
'7=left, 8=top, 9=bottom, 10=right
'
With Cells(CI, CJ).Borders(bNum)
    .LineStyle = xlContinuous
    .Color = BCol
    .Weight = BTick
End With

End Sub

Sub Deformat(I As Long, J As Long)
Dim K As Long
        Cells(I, J).Interior.Color = xlNone
        Cells(I, J).ClearContents
        For K = 7 To 10
            If Cells(I, J).Borders(K).Color <> BCol Then
                Cells(I, J).Borders(K).LineStyle = xlNone
            End If
        Next K
End Sub


Fai sapere...

(saluta Susi)

[recalcatiiti]

Ciao Anthony, funziona alla perfezione, ti ringrazio.

La Susi ricambia alla prossima!