Ciao Massimo,
In attesa del tuo file, ho scaricato una lista dei comuni per provincia
**http://lab.comuni-italiani.it/files/listacomuni.zip**
dal sito **http://www.comuni-italiani.it/** per ottenere una lista di 8093 righe del genere:
Per ottenere un report dei comuni, elencati, in modo orrizontale, con una riga per provincia, e ordinato per provincia, del tipo:
prova qualcosa del genere:
'=========>>
Option Explicit
'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim srcSH As Worksheet, destSH As Worksheet
Dim srcRng As Range, destRng As Range
Dim mainDic As Object
Dim provinciaDic As Object
Dim arrIn As Variant, arrOut As Variant
Dim arrKeys As Variant, arrKeys2 As Variant, arrHeaders As Variant
Dim sProvincia As String, sComune As String, aProvincia As String
Dim i As Long, j As Long, k As Long, p As Long
Dim iMax As Long, iCount As Long
Dim Lrow As Long
Dim bFlag As Boolean
ReDim arrOut(1 To 150, 1 To 400)
Const sFoglioDati As String = "ListaComuni" '<<=== Modifica
Const sFoglioRisultatiOrrizontali As String = "Report"
'<<=== Modifica
Set WB = ThisWorkbook
bFlag = SheetExists(sFoglioRisultatiOrrizontali, WB)
With WB
Set srcSH = .Sheets(sFoglioDati)
If bFlag Then
Set destSH = .Sheets(sFoglioRisultatiOrrizontali)
destSH.UsedRange.ClearContents
Else
Set destSH = .Sheets.Add(After:=srcSH)
destSH.Name = sFoglioRisultatiOrrizontali
End If
End With
With srcSH
Lrow = LastRow(srcSH, .Columns("A:A"))
Set srcRng = .Range("A2:C" & Lrow)
End With
arrIn = srcRng.Value
Set mainDic = CreateObject("Scripting.Dictionary")
Set provinciaDic = CreateObject("Scripting.Dictionary")
mainDic.CompareMode = vbTextCompare
provinciaDic.CompareMode = vbTextCompare
For i = 1 To UBound(arrIn)
sProvincia = arrIn(i, 3)
sComune = arrIn(i, 2)
If mainDic.Exists(sProvincia) Then
Set provinciaDic = mainDic(sProvincia)
If provinciaDic.Exists(sComune) Then
Else
provinciaDic.Add Key:=sComune, Item:=Nothing
End If
Else
Set provinciaDic = CreateObject("Scripting.Dictionary")
provinciaDic.Add Key:=sComune, Item:=Nothing
mainDic.Add Key:=sProvincia, Item:=provinciaDic
End If
sProvincia = arrIn(i, 1)
sComune = arrIn(i, 2)
Next i
iCount = mainDic.Count
arrKeys = mainDic.Keys
For j = 1 To iCount
aProvincia = arrKeys(j - 1)
Set provinciaDic = mainDic(aProvincia)
With provinciaDic
arrKeys2 = .Keys
If .Count > iMax Then
iMax = .Count
End If
End With
For k = 1 To provinciaDic.Count
arrOut(j, 1) = aProvincia
arrOut(j, k + 1) = arrKeys2(k - 1)
Next k
Next j
Set destRng = destSH.Range("A1").Resize(iCount, iMax)
ReDim arrHeaders(1 To iMax)
QuickSort arrOut, 1, 1, iCount, True
With destRng
arrHeaders(1) = "Provincia"
For p = 2 To iMax
arrHeaders(p) = "Comune " & p - 1
Next p
.Offset(1).Value = arrOut
.Rows(1).Value = arrHeaders
.EntireColumn.AutoFit
End With
Call MsgBox( _
Prompt:="Finito", _
Buttons:=vbInformation, _
Title:="REPORT")
End Sub
'--------->>
Public Function SheetExists(sSheetName As String, _
Optional ByVal WB As Workbook) As Boolean
On Error Resume Next
If WB Is Nothing Then
Set WB = ThisWorkbook
End If
SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))
End Function
'--------->>
Public Sub QuickSort(SortArray, col, L, R, bAscending)
'\ TomOgilvy: http://goo.gl/ninpZW
'Originally Posted by Jim Rech 10/20/98 Excel.Programming
'Modified to sort on first column of a two dimensional array
'Modified to handle a second dimension greater than 1 (or zero)
'Modified to do Ascending or Descending
Dim i, j, X, Y, mm
i = L
j = R
X = SortArray((L + R) / 2, col)
If bAscending Then
While (i <= j)
While (SortArray(i, col) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
Else
While (i <= j)
While (SortArray(i, col) > X And i < R)
i = i + 1
Wend
While (X > SortArray(j, col) And j > L)
j = j - 1
Wend
If (i <= j) Then
For mm = LBound(SortArray, 2) To UBound(SortArray, 2)
Y = SortArray(i, mm)
SortArray(i, mm) = SortArray(j, mm)
SortArray(j, mm) = Y
Next mm
i = i + 1
j = j - 1
End If
Wend
End If
If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)
If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)
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
'--------->>
Public Function LastCol(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
On Error Resume Next
LastCol = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
'<<=========
Potresti scaricare il mio file di prova Massimo20170413.xlsm a:
https://www.dropbox.com/s/y80g68i6mtnj0yr/Massimo20170413.xlsm?dl=0
Nonostante la lunghezza del codice, si tratta di un tempo di esecuzione di circa 0,1 secondi.
===
Regards,
Norman
![](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)
