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

Spero di aver creato correttamente il link

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

Answer 3

Ciao Luca,

ci siamo quasi, ma accade una cosa strana:

• se utilizzo la macro su un file di piccole dimensioni (numero di righe e di colonne da trasformare), la macro funziona perfettamente;
• se il numero di dati supera una certa soglia il risultato è un foglio con i dati sulle colonne casuali (vengono ripetuti i dati della prima colonna enne volte) e scombinati e oltre un certo numero di riga riporta in ogni cella il valore #N/D

E' come se la macro, oltre un certo numero di dati scrivesse sopra i record già scritti.

Ho fatto alcune prove per cercare di capire quale sia il limite di dati oltre il quale si genera il problema.

Ho scoperto che il problema nasce quando si raggiunge un numero di dati tra questi due limiti:

• 20 mila righe del file di input con 62000 righe da generare nel file di output (macro funziona)
• 22 mila righe del file di input con 68356 righe da generare nel file di output (macro non funziona).

... non me ne intendo, ma tra i due valori di righe da generare c'è 64 mila e qualcosa righe mi fa ricordare il limite di righe di un foglio excel nelle versioni precedenti ('97 o 2003).

Se avessi rivelato il fatto importante che il tuo file comprendeva oltre 22.000 righe e più di 64.000 righe di output, avrei suggerito un codice diverso perché avrei previsto un problema significativo.

Per consentirmi di testare il codice modificato, ti chiedo gentilmente di caricare un file di esempio con queste nuove dimensioni.

===

Regards,

Norman

Answer 4

Buongiorno Norman,

ci siamo quasi, ma accade una cosa strana:

• se utilizzo la macro su un file di piccole dimensioni (numero di righe e di colonne da trasformare), la macro funziona perfettamente;
• se il numero di dati supera una certa soglia il risultato è un foglio con i dati sulle colonne casuali (vengono ripetuti i dati della prima colonna enne volte) e scombinati e oltre un certo numero di riga riporta in ogni cella il valore #N/D

E' come se la macro, oltre un certo numero di dati scrivesse sopra i record già scritti.

Ho fatto alcune prove per cercare di capire quale sia il limite di dati oltre il quale si genera il problema.

Ho scoperto che il problema nasce quando si raggiunge un numero di dati tra questi due limiti:

• 20 mila righe del file di input con 62000 righe da generare nel file di output (macro funziona)
• 22 mila righe del file di input con 68356 righe da generare nel file di output (macro non funziona).

... non me ne intendo, ma tra i due valori di righe da generare c'è 64 mila e qualcosa righe mi fa ricordare il limite di righe di un foglio excel nelle versioni precedenti ('97 o 2003).

grazie mille

Answer 5

Ciao Luca,

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

Toglie tutti gli spazi e righe vuote in queste parti del codice. Oppure, più semplicemente, copia il codice dal mio file di esempio (più sotto).

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

Prova a sostituire il 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 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 = 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

    With destRng

        .CurrentRegion.ClearContents

        .Resize(iCtr, 15).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

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

Potresti scaricare il mio file di prova Luca20191028.xlsm

===

Regards,

Norman