Macro excel per trasformare colonne in righe

Question

Buongiorno,

ho un file excel molto grande costituito da alcune colonne iniziali con dei campi chiave per identificare il record e poi un certo numero di colonne, variabile in funzione dell'epoca di creazione del file, che riportano il valore, se esistente, per ogni variabile indicata nell'intestazione di colonna.

Esempio:

Numero rapporto    Codice Cliente    Prodotto A       Prodotto B      Prodotto C   Prodotto D ...

001                               AAA                   10                        0                  7                  <vuoto>

002                               AAA                     5                      <vuoto>      <vuoto >           3

007                               BBB                   <vuoto>               1                   2                 <vuoto>

Avrei bisogno di una macro che mi "normalizzasse il file in questo modo:

Numero rapporto    Codice Cliente    TIPO PRODOTTO       VALORE

001                              AAA                  Prodotto A                 10

001                              AAA                  Prodotto C                   7

002                              AAA                  Prodotto A                   5

002                              AAA                  Prodotto D                   3

007                              BBB                   Prodotto B                   1

007                              BBB                   Prodotto C                    2

In altri termini le intestazioni di colonna a partire dalla colonna N (celle N1:XX1) diventano dei Valori da inserire in una nuova colonna Tipo Prodotto a cui viene abbinato il VALORE, solo quando la cella corrispondente nel file di origine non è Vuota e >0.

Grazie

Answer 1

Ciao Luca,

Spero di aver creato correttamente il link

https://1drv.ms/x/s!AujNcnur4n1ohwW7eCnlgTncKK2q

Prova a sostituire il tuo codice con la seguente versione:

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

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 arrTranspose() As Variant

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

    Dim p As Long, q As Long

    Dim iCtr As Long

    Dim LRow As Long

    Const sFoglio_Sorgente As String = "Margine"       '<<=== Modifica

    Const sFoglio_Destinazione As String = "Report"    '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets(sFoglio_Sorgente)

        Set destSH = .Sheets(sFoglio_Destinazione)

    End With

    With srcSH

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

        Set srcRng = .Range("A1:BX" & LRow)

    End With

    Set destRng = destSH.Range("A2")

    arrIn = srcRng.Value

    For i = 2 To UBound(arrIn)

        For j = 14 To UBound(arrIn, 2)

            If arrIn(i, j) > 0 Then

                iCtr = iCtr + 1

                ReDim Preserve arrOut(1 To 15, 1 To iCtr)

                For k = 1 To 13

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

                Next k

                arrOut(14, iCtr) = arrIn(1, j)

                arrOut(15, iCtr) = arrIn(i, j)

            End If

        Next j

    Next i

    ReDim arrTranspose(1 To iCtr, 1 To 15)

    For p = 1 To UBound(arrOut)

        For q = 1 To UBound(arrOut, 2)

            arrTranspose(q, p) = arrOut(p, q)

        Next q

    Next p

    Application.ScreenUpdating = False

    With destRng

        .CurrentRegion.ClearContents

        .Resize(iCtr, 15).Value = arrTranspose

        .CurrentRegion.EntireColumn.AutoFit

    End With

    Application.ScreenUpdating = True

    Call MsgBox( _

         Prompt:="Fatto", _

         Buttons:=vbInformation, _

         Title:="REPORT")

End Sub

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

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    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

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

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

Eseguendo questo codice, ottengo un report di  102.967 righe e 76 colonne. Nota che, date le dimensioni del file, il completamento del codice richiederà circa due minuti. 

Potresti scaricare il mio file di prova Luca20191029.xlsb

===

Regards,

Norman

Answer 2

Buongiorno Norman,

grazie molto per l'aiuto. Probabilmente la mia spiegazione non conteneva tutti i dettagli necessari. Registro infatti, alcuni problemi nella macro:

Quando creo (copio) la macro una parte del codice mi rimane in rosso, come se contenesse degli errori:

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

e più sotto:

LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

Inoltre nel mio esempio semplificato il numero di colonne "fisse" erano 2, mentre nel file reale le colonne che devono restare fisse sono 13. Questo come incide sul codice? Penso che io debba cambiare qualche valore in questa parte di codice:

Set destRng = destSH.Range("A2")

    arrIn = srcRng.Value

    For i = 2 To UBound(arrIn)

        For j = 3 To UBound(arrIn, 2)

            If arrIn(i, j) > 0 Then

                iCtr = iCtr + 1

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

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

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

                arrOut(3, iCtr) = arrIn(1, j)

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

            End If

        Next j

    Next i

grazie mille

Luca

Answer 3

Ciao IL_69,

ho un file excel molto grande costituito da alcune colonne iniziali con dei campi chiave per identificare il record e poi un certo numero di colonne, variabile in funzione dell'epoca di creazione del file, che riportano il valore, se esistente, per ogni variabile indicata nell'intestazione di colonna.

Esempio:

Numero rapporto    Codice Cliente    Prodotto A       Prodotto B      Prodotto C   Prodotto D ...

001                               AAA                   10                        0                  7                  <vuoto>

002                               AAA                     5                      <vuoto>      <vuoto >           3

007                               BBB                   <vuoto>               1                   2                 <vuoto>

Avrei bisogno di una macro che mi "normalizzasse il file in questo modo:

Numero rapporto    Codice Cliente    TIPO PRODOTTO       VALORE

001                              AAA                  Prodotto A                 10

001                              AAA                  Prodotto C                   7

002                              AAA                  Prodotto A                   5

002                              AAA                  Prodotto D                   3

007                              BBB                   Prodotto B                   1

007                              BBB                   Prodotto C                    2

In altri termini le intestazioni di colonna a partire dalla colonna N (celle N1:XX1) diventano dei Valori da inserire in una nuova colonna Tipo Prodotto a cui viene abbinato il VALORE, solo quando la cella corrispondente nel file di origine non è Vuota e >0.

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IMper 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 i As Long, j As Long, k As Long

    Dim iCtr As Long

    Dim LRow As Long

    Const sFoglio_Sorgente As String = "Foglio1"          '<<=== Modifica

    Const sFoglio_Destinazione As String = "Foglio2"    '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets(sFoglio_Sorgente)

        Set destSH = .Sheets(sFoglio_Destinazione)

    End With

    With srcSH

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

        Set srcRng = .Range("A1:XX" & LRow)

    End With

    Set destRng = destSH.Range("A2")

    arrIn = srcRng.Value

    For i = 2 To UBound(arrIn)

        For j = 3 To UBound(arrIn, 2)

            If arrIn(i, j) > 0 Then

                iCtr = iCtr + 1

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

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

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

                arrOut(3, iCtr) = arrIn(1, j)

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

            End If

        Next j

    Next i

    With destRng

        .CurrentRegion.ClearContents

        .Resize(iCtr, 4).Value = Application.Transpose(arrOut)

    End With

End Sub

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

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    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

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

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 IL20191025.xlsm

===

Regards,

Norman

Answer 4

Grazie del suggerimento!

Answer 5

Ciao IL_69,

per ottenere assistenza specializzata per questo tipo di richieste relativa alla creazione di una MACRO, ti suggerisco di fare affidamento al nostro forum specializzato in questi quesiti, raggiungibile tramite questo link.

In alto a destra, clicca su "formula una domanda" e poni la tua domanda al forum.

Mi auguro di esserti stato di aiuto.

Ti auguro una buona giornata.

Dario