Ciao Nicola,
vedo che il buon Norman ha dato una soluzione con formule.
Nel frattempo mi ero cimentato nel provare a trovare una possibile soluzione al caso specifico.
Prova a vedere questo file: File esempio
Nel Modulo1 è presente questo codice:
'---
Option Explicit
Sub TrasponiValori()
Const sPrimaCella As String = "A1"
Const sIntestazioneID As String = "ID_Parent"
Const sIntestazioneTurno As String = "Turno"
Const iColID As Long = 1
Const iColTurno1 As Long = 5 '<--- da personalizzare
Const iColUltimoTurno As Long = 7 '<--- da personalizzare
Const NumCampiDatiTrasposti = 2
Dim WsDati As Worksheet
Dim rPrimaCella As Range
Dim rIntervalloDati As Range
Dim arrDati As Variant
Dim NumRec As Long, NumCol As Long
Dim i As Long, j As Long
Dim NumRecTrasposti As Long
Dim cont As Long
Dim arrDatiTrasposti() As Variant
Dim NewWb As Workbook
Dim sNomeFile As String
Set WsDati = ActiveSheet
Set rPrimaCella = WsDati.Range(sPrimaCella)
Set rIntervalloDati = rPrimaCella.CurrentRegion
With rIntervalloDati
NumRec = .Rows.Count
NumCol = .Columns.Count
arrDati = .Value
End With
'termino la procedura se non sono rispettate alcune condizioni
If arrDati(1, iColID) <> sIntestazioneID Then Exit Sub
If NumRec <= 1 Then Exit Sub
If NumCol < iColUltimoTurno Then Exit Sub
'riporto i dati in una matrice trasposta
NumRecTrasposti = NumRec * (iColUltimoTurno - iColTurno1 + 1)
ReDim arrDatiTrasposti(1 To NumRecTrasposti, 1 To NumCampiDatiTrasposti)
'intestazioni dei dati trasposti
arrDatiTrasposti(1, 1) = "ID_Fruitore"
arrDatiTrasposti(1, 2) = "Turno"
cont = 1
'inserimento dati trasposti
For i = 2 To NumRec
For j = 1 To (iColUltimoTurno - iColTurno1 + 1)
cont = cont + 1
arrDatiTrasposti(cont, 1) = arrDati(i, 1)
arrDatiTrasposti(cont, 2) = arrDati(i, j + iColTurno1 - 1)
Next j
Next i
'finestra di dialogo per salvare una nuova cartella di lavoro
With Application.FileDialog(msoFileDialogSaveAs)
If .Show = -1 Then
sNomeFile = .SelectedItems(1)
End If
End With
If sNomeFile <> "" Then
Set NewWb = Application.Workbooks.Add(1)
With NewWb
.Worksheets(1).Range("A1").Resize(NumRecTrasposti, 2).Value = arrDatiTrasposti
On Error GoTo GestisciErrori
Application.DisplayAlerts = False
.SaveAs Filename:=sNomeFile, FileFormat:=xlOpenXMLWorkbook
RiprendiErrori:
Application.DisplayAlerts = True
End With
End If
Exit Sub
GestisciErrori:
Debug.Print Err.Description
Select Case Err.Description
Case "Impossibile salvare la cartella di lavoro con lo stesso nome " & _
"di una cartella di lavoro o di un componente aggiuntivo aperto. " & _
"Scegliere un nome differente o chiudere la cartella di lavoro aperta " & _
"prima di salvare."
MsgBox "Si sta cercando di salvare il file assegnando un nome di un file aperto." & vbNewLine & _
"Chiudere il file prima di salvarne uno nuovo con lo stesso nome.", vbExclamation, "Salvataggio File Dati Trasposti"
Case Else
MsgBox "Si è verificato un errore VBA imprevisto!" & vbNewLine & _
"Errore n. " & Err.Number & vbNewLine & _
Err.Description, vbCritical, "Errore VBA"
End Select
Resume RiprendiErrori
End Sub
'---
La routine lavora sul foglio attivo (quindi utilizzabile anche per cartelle di lavoro diverse rispetto a quella in cui si trova al routine (es. nella cartella di lavoro personal associata ad un qualcue pulsante personalizzato nella barra di Excel o nella
barra rapida).
Con queste costanti puoi indicare rispettivamente in che indice di colonna dell'intervallo si trovano rispettivamente la colonna degli ID, la colonna del 1° turno e la colonna dell'ultimo turno (nel caso fosse variabile o ci fossero altre colonne successive
da non considerare).
Viene creata una matrice con i valori "trasposti", si apre una finestra di dialogo che consente di assegnare un nome ad un file (evenutalmente indicando anche un percorso diverso da quello proposto), crea una nuova cartella di lavoro, che viene salvata in
formato xlsx, e riporta nel foglio 1 i valori trasposti.
Prova a vedere se funziona con i tuoi casi reali.
ciao
p.s. rispetto alla richiesta di avera una procedura che possa essere facilmente adattata alle varie casistiche, almeno per me, è difficile pensarla senza sapere quali possano essere le altre casistiche.
Questa procedura si basa sulla struttura che tu hai postato con possibilità di adattarla a più colonne di turni che siano tra loro però consecutive.
![](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)
