Option Explicit

Sub group()
Dim objConnection As Object
Dim rs As Object
Dim rstmp As Object, rstmp2 As Object
Dim s As String, m As String
Dim j As Long, k As Long, c As Long
Dim v As Variant

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1

    Sheets.Add.Name = "Result"
    
    s = ThisWorkbook.Path & "	emporary.xlsx"
    ThisWorkbook.SaveCopyAs s
    
    Set objConnection = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    Set rstmp = CreateObject("ADODB.Recordset")
    Set rstmp2 = CreateObject("ADODB.Recordset")
    
    objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & s & ";Extended Properties=""Excel 8.0;HDR=Yes;"";"
    
    rs.Open "SELECT DISTINCT Commessa FROM [Macro$A1:J16]", _
        objConnection, adOpenStatic, adLockOptimistic, adCmdText
        
    rstmp2.Open "SELECT * FROM [Macro$A1:J16]", _
        objConnection, adOpenStatic, adLockOptimistic, adCmdText
    c = rstmp2.Fields.Count
    
    
    Dim i As Integer
    
    Do Until rs.EOF
        Cells(j + 1, 1) = rs("Commessa")
        m = ""
        k = 1
        For i = 1 To c - 1
            rstmp.Open "SELECT DISTINCT [" & rstmp2.Fields(i).Name & "] FROM [Macro$A1:J16] WHERE Commessa = '" & rs("Commessa") & "'", _
                objConnection, adOpenStatic, adLockOptimistic, adCmdText
            m = ""
            Do Until rstmp.EOF
                m = m & rstmp(rstmp2.Fields(i).Name) & "/"
                rstmp.movenext
            Loop
            m = Left(m, Len(m) - 1)
            m = Replace(m, "//", "/")
            If Left(m, 1) = "/" Then m = Mid(m, 2)
            k = k + 1
            Cells(j + 1, k) = m
            m = ""
            rstmp.Close
        Next
        j = j + 1
        rs.movenext
    Loop 
    
    rs.Close
    objConnection.Close
    Kill s
End Sub

Option Explicit

Sub GroupT()
    Dim dicA As Object
    Dim dicB As Object
    Dim Itm
    Dim sh As Worksheet
    Dim sh_Result As Worksheet
    Dim nCol As Long
    Dim Rng_Filter As Range
    Dim cell As Range
    Dim Lr_sh As Long
    Dim StrUnito As String
    Dim M_Value(1 To 10) As String ' Vettore riga

 
    Set sh = Worksheets("Macro")
    Set sh_Result = ThisWorkbook.Worksheets.Add
    
    Lr_sh = sh.Range("A1").End(xlDown).Row
    
    Set dicA = CreateObject("Scripting.Dictionary")
    Set dicB = CreateObject("Scripting.Dictionary")
    
    ' Trovo i valori univoci della colonna A
    For Each cell In sh.Range("A2:A" & Lr_sh)
        If Not dicA.Exists(cell.Value) Then
            dicA.Add Key:=cell.Value, Item:=""
        End If
    Next
    
    ' Ciclo i valori univoci della dicA ed estrapolo la stringa da riportare su ogni colonna-
    For Each Itm In dicA.Keys
        sh.Range("A1").AutoFilter field:=1, Criteria1:=Itm
        M_Value(1) = Itm

        For nCol = Columns("B").Column To Columns("J").Column
            Set Rng_Filter = Range(sh.Cells(1, nCol), sh.Cells(Lr_sh, nCol)).Offset(1).Resize(Lr_sh - 1).SpecialCells(xlCellTypeVisible)
            dicB.RemoveAll
            StrUnito = ""
            
                ' costruisco la stringa da riportare nella relativa colonna
                For Each cell In Rng_Filter
                    If Not cell.Value = "" And Not dicB.Exists(cell.Value) Then
                        dicB.Add cell.Value, ""
                        StrUnito = StrUnito & cell.Value & "/"
                    End If
                Next
                
            ' riporto la stringa nell'elemento della matrice
            If StrUnito = "" Then
                M_Value(nCol) = ""
            Else
                M_Value(nCol) = Left(StrUnito, Len(StrUnito) - 1)
            End If
            
        Next
        
        ' Riporto il vettore M_Value nella sua destinazione finale
        sh_Result.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(1, 10).Value = M_Value
        Erase M_Value
    
    Next
    
    sh.AutoFilterMode = False
    
    Set dicA = Nothing
    Set dicB = Nothing
    Set sh_Result = Nothing
    Set sh = Nothing
    
End Sub