![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
Microsoft 365 e Office | Excel | Per la casa | Windows
Una famiglia di software per fogli di calcolo Microsoft con strumenti per l'analisi, la creazione di grafici e la comunicazione dei dati.
Ciao tex_willer,
No, al massimo la situazione che si potrebbe presentare è questa.
RAGIONE SOCIALE INDIRIZZO E- MAIL azienda1 srl via pippo, 1 abc @ yyy.com azienda1 srl abc @ yyy.com azienda1 srl abc @ yyy.com azienda1 srl via pippo, 1 abc @ yyy.com
Prova qualcosa del genere:
- Alt+F11 per aprire l'editor di VBA
- Alt+IMper inserire un nuovo modulo di codice
- Nel nuovo modulo vuoto, incolla il seguente codice:
'=========>>
Option Explicit
'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim oDicAzienda As Dictionary
Dim oDicIndirizzo As Dictionary
Dim oDicEmail As Dictionary
Dim vArr As Variant, vArrDelete() As Variant
Dim vArrKeysIndirizzo As Variant, varrKeysEmail As Variant
Dim vArrOut() As Variant
Dim sStr As String, aStr As String
Dim LRow As Long
Dim i As Long, j As Long, k As Long
Dim sAzienda As String, sIndirizzo As String, sEmail As String
Dim bIndirizzo As Boolean, bEmail As Boolean
Const sNomeFoglio As String = "Foglio1" '<<==== Modifica
Set WB = ThisWorkbook
Set SH = WB.Sheets(sNomeFoglio)
With SH
LRow = LastRow(SH, .Columns("A:A"))
Set Rng = .Range("A2:C" & LRow)
End With
Set oDicAzienda = New Dictionary
Set oDicIndirizzo = New Dictionary
Set oDicEmail = New Dictionary
vArr = Rng.Value
For i = 1 To UBound(vArr)
sAzienda = vArr(i, 1)
sIndirizzo = vArr(i, 2)
sEmail = vArr(i, 3)
bIndirizzo = sIndirizzo <> vbNullString
bEmail = sEmail <> vbNullString
With oDicAzienda
Rng.Cells(i, "A").Select
If Not .Exists(sAzienda) Then
.Add Key:=sAzienda, Item:=sIndirizzo
Else
If bIndirizzo Then
.Item(sAzienda) = sIndirizzo
End If
j = j + 1
ReDim Preserve vArrDelete(1 To j)
vArrDelete(j) = i + 1 & ":" & i + 1
End If
End With
If bIndirizzo Then
With oDicIndirizzo
If Not .Exists(sIndirizzo) Then
.Add Key:=sIndirizzo, Item:=sAzienda
End If
End With
End If
If bEmail Then
With oDicEmail
If Not .Exists(sAzienda) Then
.Add Item:=sEmail, Key:=sAzienda
End If
End With
End If
Next i
sStr = Join(vArrDelete, ",")
vArrKeysIndirizzo = oDicIndirizzo.Keys
varrKeysEmail = oDicEmail.Keys
ReDim arrOut(1 To oDicAzienda.Count, 1 To 3)
For k = 1 To oDicAzienda.Count
aStr = oDicAzienda.Keys(k - 1)
arrOut(k, 1) = aStr
arrOut(k, 2) = oDicAzienda.Item(aStr)
arrOut(k, 3) = oDicEmail.Item(aStr)
Next k
With Rng
.ClearContents
On Error GoTo XIT
Application.ScreenUpdating = False
.Resize(oDicAzienda.Count, 3).Value = arrOut
End With
XIT:
Set oDicAzienda = Nothing
Set oDicIndirizzo = Nothing
Set oDicEmail = Nothing
Application.ScreenUpdating = True
End Sub
'--------->>
Public Function LastRow(SH As Worksheet, _
Optional Rng As Range, _
Optional minRow As Long = 1)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
On Error Resume Next
LastRow = Rng.Find(What:="*", _
after:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
If LastRow < minRow Then
LastRow = minRow
End If
End Function
'<<=========
- Alt+Q per chiudere l'editor di VBA e tornare a Excel
- Salva il file con l’estensione xlsm
- Alt+F8 per aprire la finestra di gestione delle macro
- Seleziona Tester | Esegui
Potresti scaricare il mio file di prova Tex_Willer20160516.xlsm a:
https://www.dropbox.com/s/qgnics554i3b2a4/Tex_Willer20160516.xlsm?dl=0
===
Regards,
Norman