• VBA
• Excel

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

• Indietro
• Avanti