Questo sito utilizza cookie, anche di terze parti, per migliorare la tua esperienza e offrire servizi in linea con le tue preferenze. Chiudendo questo banner, scorrendo questa pagina o cliccando qualunque suo elemento acconsenti all’uso dei cookie

Rimani informato sugli aggiornamenti di SOS-OFFICE. Inserisci il tuo indirizzo e-mail: Informativa sulla privacy

Molti dei nostri lettori si saranno accorti che Excel non dispone di una funzionalità semplice per estrarre i dati univoci da un intervallo disposto su più colonne. Per risolvere questo problema si può ricorrere a VBA.

 

Il codice da usare è i seguente. Questo codice permette all'utente di selezionare in maniera interattiva tramite una finestra di Input l'intervallo da cui estrarre i valori univoci (Application.InputBox). Scrive i dati estratti nella cella attiva (dopo aver verificato che la cella attiva non si trovi all'interno dell'intervallo dei dati di origine (Application.Intersect)) e li mette in ordine alfabetico.

Dim dati(1 To 100) As String
Dim numElem As Integer  ' numero di elementi nel vettore dati
Dim riga As Integer
Dim colonna As Integer
Public Sub EstraiUnivoci()
Dim intervallo As Range
Dim cella As Range

numElem = 0

riga = ActiveCell.Row

colonna = ActiveCell.Column

On Error Resume Next

Set intervallo = _
Application.InputBox("Seleziona l'intervallo da cui estrarre i dati univoci", _

"Seleziona!", Type:=8)


If intervallo Is Nothing Then

Exit Sub

Else

If Interseca(ActiveCell, intervallo) Then

MsgBox "Attenzione la cella attiva ricade " & _

"nell'intervallo dei dati, spostati e riprova"

Exit Sub

Else

For Each cella In intervallo

inserisci (cella)

Next

Erase dati

Cells(riga, colonna).CurrentRegion.Sort Key1:=Cells(riga, colonna), Order1:=xlAscending, Header:=xlNo

End If

Exit Sub
End If

End Sub
Private Sub inserisci(valore)

Dim trovato As Boolean>

trovato = False


' Cerca il valore da inserire nel vettore dati

' Se trovato, esce dal ciclo

For i = 1 To numElem

If UCase(dati(i)) = UCase(valore) Then

trovato = True

Exit For

End If

Next

' Se il valore non è stato trovato nella ricerca precendente

' vuol dire che manca e quindi lo inserisco nel vettore

' incrementando la variabile con il numero di elementi

If Not trovato Then
If Not IsEmpty(valore) Then

numElem = numElem + 1

dati(numElem) = valore



ActiveSheet.Cells(riga - 1 + numElem, colonna) = UCase(Left(valore, _

1)) & LCase(Right(valore, Len(valore) - 1))
End If
End If


End Sub
Public Function Interseca(intervallo1, intervallo2)

Dim intersezione As Range


Set intersezione = Application.Intersect(intervallo1, intervallo2)

If Not intersezione Is Nothing Then

Interseca = True

Else

Interseca = False

End If

End Function
Joomla templates by a4joomla