Ciao Giuseppe,
Buongiorno.
Ho la necessita che da una matrice di dati in un Foglio vorrei raggruppare in modalità diversi i dati in due altri Fogli. Non sono riuscito a farlo con le Funzioni presenti in Excel e chiedo perciò che qualcuno possa gentilmente aiutarmi con un codice.
Allego una immagine della Matrice di base e del tipo di raggruppamento che vorrei. Le variabili sono nella colonna C della matrice di base e possono assumere valore di "L" , di "P" o nessun valore. Il raggruppamento vorrei avvenisse secondo lo schema.
- Alt+F11 per aprire l'editor di VBA
- Alt+IM per inserire un nuovo modulo di codice
- Nel nuovo modulo vuoto, incolla il seguente codice:
'=========>>
Option Explicit
'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim srcSH As Worksheet, destSH As Worksheet
Dim srcRng As Range, destRng As Range
Dim arrIn As Variant, arrUnique As Variant, arrOut() As Variant
Dim LRow As Long
Dim i As Long, j As Long, k As Long
Dim CalcMode As Long
Const sFoglio As String = "Foglio1" '<<=== Modifica
Const iRigaIntestazioni As Long = 3 '<<=== Modifica
Set WB = ThisWorkbook
Set srcSH = WB.Sheets(sFoglio)
With srcSH
LRow = LastRow(srcSH, .Columns("A:A"))
Set srcRng = .Range("A" & iRigaIntestazioni + 1) _
.Resize(LRow - iRigaIntestazioni, 3)
End With
arrIn = srcRng.Value
arrUnique = SortedUniqueList(srcRng.Columns(3).Value)
On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For i = 1 To UBound(arrUnique)
k = 0
For j = 1 To UBound(arrIn)
If arrIn(j, 3) = arrUnique(i) Then
k = k + 1
ReDim Preserve arrOut(1 To 2, 1 To k)
arrOut(1, k) = arrIn(j, 3)
arrOut(2, k) = arrIn(j, 1)
End If
Next j
With WB
Set destSH = .Sheets.Add(After:=.Sheets(.Sheets.Count))
End With
Set destRng = destSH.Range("A2").Resize(2, UBound(arrOut, 2))
With destRng
.Value = arrOut
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Erase arrOut
Next i
Call MsgBox( _
Prompt:="Finito!", _
Buttons:=vbInformation, _
Title:="REPORT")
XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
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 SortedUniqueList(V As Variant)
Dim oSortedUniqueList As Object
Dim arrOut() As Variant
Dim sStr As String
Dim i As Long
Set oSortedUniqueList = CreateObject("System.Collections.Sortedlist")
With oSortedUniqueList
For i = LBound(V) To UBound(V, 1)
sStr = V(i, 1)
If Not sStr = vbNullString Then
If Not .ContainsKey(sStr) Then
.Add Key:=sStr, Value:=i
End If
End If
Next i
ReDim arrOut(1 To .Count)
For i = 0 To .Count - 1
arrOut(i + 1) = .GetKey(i)
Next i
End With
SortedUniqueList = arrOut
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 Giuseppe20160624.xlsm
===
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)
