Macro per IncollaTrasponi

Hai un problema con Excel?

Nuova discussione

Macro per Incolla/Trasponi
di PINIL data: 12/01/2017 17:04:50
Un cordiale saluti a tutti.

Per facilità espositiva, allego un file Excel composto da 2 schede: “Elenco di Partenza” e “Elenco Rielaborato”.

Nella scheda ’Elenco di Partenza” ho un elenco ordinato sul cognome del Cliente il quale appare in tanti record quanti sono i prodotti che per quel giorno il Cliente ha ordinato. In tale elenco i Clienti possono essere svariate decine (a volte anche centinaia), mentre la platea dei prodotti che possono acquistare, non supera i 20 tipi di prodotti diversi.

Per giungere al mio “lavoro finito” (Elenco Rielaborato) utilizzo manualmente la funzione (Copia + Incolla e Trasponi) però, trattandosi di attività lavorativa quotidiana, mi ritrovo a rielaborare tali fogli Excel con noia e forte perdita di tempo.

Richiesta: è possibile creare una macro in VBA che mi consenta di evitare tale lavoro da amanuense?

Specifico che, come si noterà nella scheda “Elenco Rielaborato”:
• non mi interessa avere l’incolonnamento dello stesso tipo di prodotto nella stessa colonna (colonna delle penne, colonna delle matite ecc.), ma il semplice risultato della funzione “Incolla e Trasponi”. L’importante è che tale funzione cominci a riempire la prima cella dopo il cognome (per intenderci dalla colonna “B”)

• non c’è un numero fisso di volte che i Clienti appaiono nell’elenco di partenza (proprio come volutamente esposto nella scheda ’Elenco di Partenza”), quindi il loro numero è estremamente variabile (in stretta dipendenza dei diversi prodotti che i Clienti, per quel giorno, hanno richiesto)

Grazie per l’aiuto che vorrete offrirmi.

PINIL
di patel data: 12/01/2017 17:54:54
hai provato ad usare il registratore di macro ? lo attivi, fai le operazioni manualmente lo fermi e vai a vedere la macro, questa non sarà quella definitiva ma un buon punto di partenza su cui lavorare
di Luca73 data: 13/01/2017 09:37:26
UN consiglio e una domanda
la tabella come l'hai creata tu è obbligatoria?
Altrimenti potresti usare una tabello Pivot che ti fa in automatico qualcosa del genere
CIao
Luca

di Luca73 data: 13/01/2017 16:05:03
In allegato una possibile soluzione con VBA
CIao
Luca

Sub IncollaTrasponi()
Dim RigaPartenza
Dim RigaArrivo
Dim IndiceArrivo
Dim Cancellare
Dim TrovatoRiga
Dim PrimaCellaArr
Dim PrimaCellaPar
Dim EsisteProdotto
Cancellare = MsgBox("Procedo e Cancello?", vbYesNo + vbQuestion, "CANCEELLO?")
If Cancellare = vbNo Then
    Exit Sub
End If
Set PrimaCellaArr = Sheets("Elenco Rielaborato").Range("A2")
With Sheets("Elenco Rielaborato").Range(PrimaCellaArr, PrimaCellaArr.End(xlDown).Offset(0, 25))
    .ClearContents
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With
Set PrimaCellaPar = Sheets("Elenco di Partenza").Range("A2")
For Each RigaPartenza In Sheets("Elenco di Partenza").Range(PrimaCellaPar, PrimaCellaPar.End(xlDown))
    If Sheets("Elenco Rielaborato").Range("A2") = "" Then
       BordiNeri (Sheets("Elenco Rielaborato").Range("A2"))
       Sheets("Elenco Rielaborato").Range("A2") = RigaPartenza
       BordiNeri (Sheets("Elenco Rielaborato").Range("A2").Offset(0, 1))
       Sheets("Elenco Rielaborato").Range("A2").Offset(0, 1) = RigaPartenza.Offset(0, 1)
    Else
        TrovatoRiga = False
        For Each RigaArrivo In Sheets("Elenco Rielaborato").Range(PrimaCellaArr, PrimaCellaArr.Offset(Rows.Count - 10, 0).End(xlUp))
            If RigaArrivo = RigaPartenza Then
                TrovatoRiga = True
                EsisteProdotto = False
                For IndiceArrivo = 2 To RigaArrivo.End(xlToRight).Column
                    If RigaArrivo.Offset(0, IndiceArrivo - 1) = RigaPartenza.Offset(0, 1) Then
                        EsisteProdotto = True
                    End If
                Next IndiceArrivo
                If Not EsisteProdotto Then
                    BordiNeri (RigaArrivo.Offset(0, RigaArrivo.End(xlToRight).Column))
                    RigaArrivo.Offset(0, RigaArrivo.End(xlToRight).Column) = RigaPartenza.Offset(0, 1)
                End If
            End If
        Next RigaArrivo
        If Not TrovatoRiga Then
            With PrimaCellaArr.Offset(Rows.Count - 10, 0).End(xlUp)
                .Offset(1, 0) = RigaPartenza
                BordiNeri (.Offset(1, 0))
                .Offset(1, 1) = RigaPartenza.Offset(0, 1)
                BordiNeri (.Offset(1, 1))
            End With
        End If
    End If
Next RigaPartenza
           
    


End Sub

Sub BordiNeri(Target As Range)
    
    With Target
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
        End With
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
End Sub

di PINIL data: 13/01/2017 20:54:45
Luca 73 = GRANDE

Funziona Perfettamente !!!
Ho fatto delle simulazioni con un numero più consistente di Clienti e di prodotti, e la macro da te approntata ha funzionato, soddisfacendo la mia esigenza lavorativa

GRAZIE 1000000000000000

Vuoi Approfondire?