Excel Macro per trasformazione dei dati con traslazione.

Question

Buongiorno a tutti,

Avrei la necessità di creare una macro che mi permetta di trasporre (da orizzontale a verticale) alcuni valori ma nel contempo ripetendone altri.

Vedo di spiegarmi meglio. Ho un foglio excel (Foglio1) che ha per esempio 50 righe. La prima riga del file excel ha le intestazioni. Tutte le successive righe rappresentano una persona diversa. Le colonne di intestazione della prima riga saranno per esempio Matricola (A1), Regione (B1), Nome (C1), Codice1 (D1), Codice2 (E2), Codice3 (F4)….Codice11 (N1). Vedi l’esempio sotto:

Ho la necessità di creare con una macro un nuovo foglio (Foglio2) in cui le prime tre colonne siano sempre le stesse Matricola (A1), Regione (B1), Nome (C1) e però ci sia una unica colonna Codice (D1) dove andrò a traslare (trasferire in verticale) tutti i codici presenti nelle colonne Codice1…Codice11. del primo foglio. I campi matricola, regione e nome dovranno essere ripetuti per ogni codice traslato nel foglio 2.

Potrebbe essere che i codici non siano sempre 11 ma per esempio 1 oppure 3 o 5 e anche 0. Per cui la macro dovrebbe creare un numero di righe uguale al numero di campi codice effettivamente presenti nella riga di riferiemnto de foglio 1. Nel caso nessuno dei campi Codice1….Codice 11 del foglio 1 sia compilato allora occorre almeno creare una riga con il solo valore della Matricola, Regione e Nome e con nessun valore per la colonna Codice.

Di seguito l’esempio di come dovrebbe essere il foglio 2 alla fine dell’esecuzione della macro.

Qualcuno mi può aiutare?

Grazie

Answer 1

Ciao Pankrazio,

La macro funziona alla grande con un unico problema dovuto però alla mia spiegazione iniziale non molto chiara. Infatti mi sono dimenticato di dire che nella colonna matricola ci possono essere valori che iniziano con lo 0, per esempio:

01114556 oppure:

00123488.

In entrambi gli esempi con la traslazione dei dati nel Foglio 2 le matricole perdono gli zero iniziali diventano dunque rispettivamente:

1114556

123488

E' possibile fare qualcosa per correggere il problema?

Prova la seguente versione del codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, rCell As Range

    Dim arrIn As Variant, arrOut() As Variant

    Dim LRow As Long, LCol As Long

    Dim i As Long, j As Long, k As Long

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets("Foglio1")

        Set destSH = .Sheets("Foglio2")

    End With

    With srcSH

        LRow = LastRow(srcSH, .Columns("A:A"))

        LCol = LastCol(srcSH, .Rows(1))

        Set srcRng = .Range("A2").Resize(LRow - 1, LCol)

    End With

    arrIn = srcRng.Value

    For i = 1 To UBound(arrIn, 1)

        For j = 4 To UBound(arrIn, 2)

            If arrIn(i, j) <> vbNullString Or j = 4 Then

                k = k + 1

                ReDim Preserve arrOut(1 To 4, 1 To k)

                arrOut(1, k) = arrIn(i, 1)

                arrOut(2, k) = arrIn(i, 2)

                arrOut(3, k) = arrIn(i, 3)

                arrOut(4, k) = arrIn(i, j)

            End If

        Next j

    Next i

    On Error GoTo XIT

    Application.ScreenUpdating = False

    With destSH

        .Range("A1:D1").Value = Array("Matricola", "Regione", "Nome", "Codice")

    With .Range("A2").Resize(k, 4)

.Columns(1).NumberFormat = "@"

.Value = Application.Transpose(arrOut)

End With

    End With

XIT:

    Application.ScreenUpdating = True

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range)

    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

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

'<<=========

===

Regards,

Norman

Answer 2

Ciao Pankrazio,

Funziona Perfettamente.

Ti ringrazio per il cortese riscontro.

Per chiudere questo thread, ti chiederei di gentilmente segnare la mia risposta come Risposta. In questo modo, tu aiuterai anche coloro che potrebbero un domani cercare soluzioni ai problemi simili negli archivi della comunità.

===

Regards,

Norman

Answer 3

Grazie Norman

Funziona Perfettamente.

Sei un grande!

Answer 4

Grazie mille Norman!!!

La macro funziona alla grande con un unico problema dovuto però alla mia spiegazione iniziale non molto chiara. Infatti mi sono dimenticato di dire che nella colonna matricola ci possono essere valori che iniziano con lo 0, per esempio:

01114556 oppure:

00123488.

In entrambi gli esempi con la traslazione dei dati nel Foglio 2 le matricole perdono gli zero iniziali diventano dunque rispettivamente:

1114556

123488

E' possibile fare qualcosa per correggere il problema?

Grazie ancora

Answer 5

Ciao Pankrazio,

• 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, arrOut() As Variant

    Dim LRow As Long, LCol As Long

    Dim i As Long, j As Long, k As Long

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets("Foglio1")                                                           '<<==== Modifica

        Set destSH = .Sheets("Foglio2")                                                         '<<==== Modifica

    End With

    With srcSH

        LRow = LastRow(srcSH, .Columns("A:A"))

        LCol = LastCol(srcSH, .Rows(1))

        Set srcRng = .Range("A2").Resize(LRow - 1, LCol)

    End With

    arrIn = srcRng.Value

    For i = 1 To UBound(arrIn, 1)

        For j = 4 To UBound(arrIn, 2)

            If arrIn(i, j) <> vbNullString Or j = 4 Then

                k = k + 1

                ReDim Preserve arrOut(1 To 4, 1 To k)

                arrOut(1, k) = arrIn(i, 1)

                arrOut(2, k) = arrIn(i, 2)

                arrOut(3, k) = arrIn(i, 3)

                arrOut(4, k) = arrIn(i, j)

            End If

        Next j

    Next i

    On Error GoTo XIT

    Application.ScreenUpdating = False

    With destSH

        .Range("A1:D1").Value = Array("Matricola", "Regione", "Nome", "Codice")

        .Range("A2").Resize(k, 4) = Application.Transpose(arrOut)

    End With

XIT:

    Application.ScreenUpdating = True

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range)

    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

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

'<<=========

• Alt-Q per chiudere l'editor di VBA e tornare a Excel.
• Alt-F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

===

Regards,

Norman