Struttura ad Albero da Verticalizzare e codice da aggiungere

Question

Ciao a tutti, come da oggetto ho l'esigenza di adattare un file in Excel con struttura ad Albero per renderla "leggibile" ad un database.

Facendo un esempio, il file è un'elaborazione di una distinta base, per cui:

Cella A1 vedo l'articolo principale,che è formato da altri articoli che sono nelle celle a destra,che a loro volta sono formati da altri articoli sempre a destra.

io invece devo verticalizzare la struttura ed aggiungere l’articolo padre a Destra

esempio:

Pippo           

                       pippo1

                       pippo2

                       pippo3         

                                             pluto1

                                             pluto2

Devono diventare

Pippo             Pippo

pippo1           Pippo

pippo2           Pippo

pippo3           Pippo

pluto1            pippo3               

pluto2            pippo3               

Spero di essere stato chiaro, grazie a tutti

Answer 1

Così adesso dovrebbe fare quello che vuoi, non è proprio perfetta come soluzione perché se hai un altro livello di distinta ti tocca entrare nel codice e cambiare le colonne UM e quantità (ti metto in grassetto il punto)... ma per il momento potresti accontentarti! ;-)

Ti posto qui sotto il codice! Ciao, Ste'

Sub Verticalizza()

    Dim nRow, nCol As Long

    Application.ScreenUpdating = False

    'per comodità sposto le colonne g ed h all'inizio

    Columns("G:H").Select    Selection.Cut

    Columns("A:A").Select

    Selection.Insert shift:=xlToRight

    Range("C1").Select

    'prima richiamo la routine di copia dei valori

    CopiaValori True, ""

    'prendo la riga della cella in cui sono arrivata

    nRow = ActiveCell.Row

    'prendo la colonna dell'ultima cella compilata

    nCol = ActiveCell.Offset(-1, 0).End(xlToRight).Column + 1

    Range("C1").Select

    'routine per eliminare le celle vuote

    EliminaVuoti nRow, nCol

    ' risposto le colonne g ed h prima dell'articolo padre alla fine

    Columns("A:B").Select

    Selection.Cut

    Columns("E:E").Select

    Selection.Insert shift:=xlToRight

    'dopo aggiungo le nuove colonne

    Columns("E:E").Select

    Selection.Insert shift:=xlToRight

    Columns("E:E").Select

    Selection.Insert shift:=xlToRight

    'aggiungo una nuova riga davanti a tutto

    Rows("1:1").Select

    Selection.Insert

    Selection.Font.Bold = True

    'metto i titoli

    Range("A1").Select

    ActiveCell.Value = "Codice"

    ActiveCell.Offset(0, 1).Value = "Descrizione"

    ActiveCell.Offset(0, 2).Value = "UM"

    ActiveCell.Offset(0, 3).Value = "Quantità"

    ActiveCell.Offset(0, 4).Value = "Prezzo"

    ActiveCell.Offset(0, 5).Value = "Commessa"

    ActiveCell.Offset(0, 6).Value = "Kit"

    Application.ScreenUpdating = True

End Sub

Function EliminaVuoti(ByVal nRowTot As Long, ByVal nColTot As Long)

    Dim nCol, nRow, nCountCol As Long

    Dim bStop As Boolean

    For nRow = 1 To nRowTot - 1

        nCountCol = 0

        bStop = False

        nCol = 1

        While (nCol <= nColTot) And Not bStop

            If IsNull(ActiveCell.Value) Or ActiveCell.Value = "" Then

                If nCountCol < 4 Then

                    Selection.Delete shift:=xlToLeft

                    If Not (IsNull(ActiveCell.Value) _

                        Or ActiveCell.Value = "") Then

                        bStop = True

                    End If

                End If

            Else

                nCountCol = nCountCol + 1

                ActiveCell.Offset(0, 2).Select

            End If

            nCol = nCol + 1

        Wend

        Cells(nRow + 1, 3).Select

    Next nRow

End Function

Function CopiaValori(ByVal bFirstCall As Boolean, ByVal sValToRip As String)

    Dim sValCella As String

    Dim bStopCurr As Boolean

    If Not bFirstCall Then

        'mi posiziono su due colonne dopo e riga successiva

        ActiveCell.Offset(1, 2).Select

    Else

        'se primo richiamo prendo solo il valore da riportare

        sValToRip = ActiveCell.Value

    End If

    While Not bStopCurr

        If ActiveCell.Value = "" Then

            'se nella cella successiva non c'è niente mi fermo

            bStopCurr = True

        Else

            'imposto il codice e des. dell'art. precedente

            ActiveCell.Offset(0, 2).Value = sValToRip

            'mi prendo il codice e descr. dell'articolo successivo

            sValCella = ActiveCell.Value

            'richiamo la sottoroutine per l'articolo successivo (se ero in A1 passo in B3)

            CopiaValori False, sValCella

            'avanzo di una riga

            ActiveCell.Offset(1, 0).Select

        End If

    Wend

    If Not bFirstCall Then

        'mi riposiziono sulla cella iniziale

        ActiveCell.Offset(-1, -2).Select

    End If

End Function

Answer 2

Naturalmente Grazie.

Ho appena provato ed effettivamente funziona,ma per mia stupidità non ho ancora il risulato corretto.

Come ho detto nel messaggio precedente oltre agli articoli ho anche le descrizioni e le quantità,li avevo omessi perchè abituato con access li avevo considerati come campi, ovviamente con Excel le cose cambiano  non complicare la comprensione ed invece ho fatto un casino.

Volendo allegare un file di esempio  come dovrei fare?.

Ancora davvero tante grazie per la pazienza

Answer 3

Usa questo codice per il tuo problema (ho cercato di strutturarlo in modo che tu posso aggiungere N livelli di distinta base).

Sub Verticalizza()

    Dim nRow, nCol As Long

    Application.ScreenUpdating = False

    Range("A1").Select

    'prima richiamo la routine di copia dei valori

    CopiaValori True, ""

    'prendo la riga della cella in cui sono arrivata

    nRow = ActiveCell.Row

    'prendo la colonna dell'ultima cella compilata

    nCol = ActiveCell.Offset(-1, 0).End(xlToRight).Column + 1

    Range("A1").Select

    'routine per eliminare le celle vuote

    EliminaVuoti nRow, nCol

    Application.ScreenUpdating = True

End Sub

Function EliminaVuoti(ByVal nRowTot As Long, ByVal nColTot As Long)

    Dim nCol, nRow, nCountCol As Long

    Dim bStop As Boolean

    For nRow = 1 To nRowTot - 1

        nCountCol = 0

        bStop = False

        nCol = 1

        While (nCol <= nColTot) And Not bStop

            If IsNull(ActiveCell.Value) Or ActiveCell.Value = "" Then

                If nCountCol < 2 Then

                    Selection.Delete Shift:=xlToLeft

                    If Not (IsNull(ActiveCell.Value) _

                        Or ActiveCell.Value = "") Then

                        bStop = True

                    End If

                End If

            Else

                nCountCol = nCountCol + 1

                ActiveCell.Offset(0, 1).Select

            End If

            nCol = nCol + 1

        Wend

        Cells(nRow + 1, 1).Select

    Next nRow

End Function

Function CopiaValori(ByVal bFirstCall As Boolean, ByVal sValToRip)

    Dim sValCella As String

    Dim bStopCurr As Boolean

    If Not bFirstCall Then

        'mi posiziono sulla colonna e riga successiva

        ActiveCell.Offset(1, 1).Select

    Else

        'se primo richiamo prendo solo il valore da riportare

        sValToRip = ActiveCell.Value

    End If

    While Not bStopCurr

        If ActiveCell.Value = "" Then

            'se nella cella successiva non c'è niente mi fermo

            bStopCurr = True

        Else

            'imposto il valore nella cella affianco

            ActiveCell.Offset(0, 1).Value = sValToRip

            'mi prendo il valore della cella dopo

            sValCella = ActiveCell.Value

            'richiamo la sottoroutine per la cella successiva (se ero in A1 passo in B2)

            CopiaValori False, sValCella

            'avanzo di una riga

            ActiveCell.Offset(1, 0).Select

        End If

    Wend

    If Not bFirstCall Then

        'mi riposiziono sulla cella iniziale

        ActiveCell.Offset(-1, -1).Select

    End If

End Function

Spero di esserti stata utile!

Ciao, Ste'

Answer 4

Grazie per la risposta, la mia intenzione era di verificare quale soluzione era la migliore,sinceramente avevo pensato proprio ad una funzione in visual basic o macro.

Nel foglio i dati sono come li vedi nel primo messaggio, con il primo codice a sinistra, gli altri che lo compongono a destra ed una riga sotto e via di questo passo.

Dovendoli però importare in Access devo per forza verticalizzare per avere tutti i codici che comporranno un campo della tabella, la loro descrizione in un altro campo (nell'esempio non è riportata perchè volevo non complicare la comprensibilità del problema), ed il riproporre il campo padre più a destra permette ad Access quando importa di abbinare correttamente i componenti).

Grazie ancora

Answer 5

Ciao,

ma lo vuoi fare con una macro o direttamente sul foglio di calcolo?

Nel foglio di input i dati come sono messi? Ok sono a dx ma iniziano dalla stessa riga o da una riga sotto?

Sara