Pagina precedente | 1 | Pagina successiva
Vota | Stampa | Notifica email    
Autore

Trasposizione automatica di colonne

Ultimo Aggiornamento: 08/12/2016 12:02
Post: 2
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
06/12/2016 16:11

Buongiorno a tutti spero di trovare un'anima buona che mi possa aiutare, ho un foglio excel che allego in cui ho due colonne con le celle che identificano le colonne in verticale con nome indirizzo telefono e fax e la colonna successiva con i nomi effettivi indirizzi effettivi ecc. ecc.
Ora ho la necessità di incolonnare tutto da verticale ad orizzontale e ho bisogno di automatizzare il tutto perchè ho migliaia di righe, mi potete aiutare.
Grazie Mille

Post: 764
Registrato il: 24/04/2004
Città: TERAMO
Età: 63
Utente Senior
2010
OFFLINE
06/12/2016 17:30

Ciao.
Se l'altezza in righe delle schede fosse sempre uguale(nell'esempio allegato non è così) si può usare questa procedura:
Option Explicit

Const cRighe = 20

Public Sub Incolonna()
Dim lRiga As LongPtr, rTabella As LongPtr
Dim Elenco As Range, Tabella As Range
    Set Elenco = Range("A2")
    Set Tabella = Range("F1")
    rTabella = 1
    For lRiga = 1 To cRighe Step 2
        Tabella(rTabella, lRiga \ 2) = Elenco(lRiga, 1)
    Next lRiga
    Do While Elenco <> ""
        rTabella = rTabella + 1
        For lRiga = 1 To cRighe Step 2
            Tabella(rTabella, lRiga \ 2) = Elenco(lRiga, 2)
        Next lRiga
        Set Elenco = Elenco(cRighe, 1)
    Loop
    Set Elenco = Nothing
    Set Tabella = Nothing
End Sub

altrimenti la cosa si complica un pò.
[Modificato da Zer0kelvin 06/12/2016 17:31]
__________________________
[Excel 2010]
-Condividere la conoscenza aumenta la ricchezza di tutti.
-Dai ad un uomo un pesce e lo avrai sfamato per un giorno; insegnagli a pescare e lo avrai sfamato per sempre. (Confucio)
-Il sonno della ragione genera mostri. (Francisco Goya)
Post: 2
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
06/12/2016 17:39

Grazie per la risposta e la formula, che devo inserire come marco nel foglio excel? Giusto? Scusami ma non sono molto pratico.
Grazie ancora
Post: 3.534
Registrato il: 13/03/2012
Città: LIVORNO
Età: 78
Utente Master
2010
OFFLINE
06/12/2016 17:44

la macro sarebbe questa
Sub trasp()
LR = Cells(Rows.Count, "A").End(xlUp).Row
dr = 2
dc = 6: LC = 15
For r = 2 To LR Step 19
  For c = dc To LC
    Cells(dr, c) = Cells(r + (c - dc) * 2, 2)
  Next
  dr = dr + 1
Next

End Sub

ma funziona soltanto se il numero delle righe di ciascuna sezione è sempre lo stesso, cosa che nell'esempio non è rispettata

----------
Win 10 - Excel 2010
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Post: 3
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
06/12/2016 17:50

Quindi il codice che hai scritto prima è VBA
Post: 4
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
06/12/2016 17:54

Ho provato ed effettivamente, come hai detto se non sono regolari viene fuori un pasticcio.
Come potrei ovviare a questo disallineamento?
Post: 3.535
Registrato il: 13/03/2012
Città: LIVORNO
Età: 78
Utente Master
2010
OFFLINE
06/12/2016 18:11

correggere i dati oppure trovare una logica, perché cambia il num di righe ?

----------
Win 10 - Excel 2010
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Post: 5
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
06/12/2016 19:16

E' un problema di dati, ovvero alcuni nominativi riportano il telefono altri no e quindi nella estrapolazione originaria del file non vi era omogeneità nei dati-
Ora provo a verificare la corretta corrispondenza.
Grazie ancora.
Post: 2.244
Registrato il: 27/09/2010
Città: FIRENZE
Età: 61
Utente Veteran
Excel 2010
OFFLINE
06/12/2016 19:21



Ciao,

mi confermi che usi Excel 2013?

Nella cella A324 manca l'indicazione "Nome".

Fatta questa correzione, puoi lavorare probabilmente con una formula

In F2 copia in basso ed a destra

=SE.ERRORE(INDICE($B$1:$B$1000;AGGREGA(15;6;RIF.RIGA($1:$1000)/($A$1:$A$1000=F$1);RIGHE($A$1:$A1)));"")


A patto che per ogni nome siano indicate le informazioni da riportare nella colonne.

Saluti
[Modificato da (Canapone) 06/12/2016 19:26]

Post: 6
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
06/12/2016 19:38

Ti confermo Excel 2013 ora provo.
Post: 2.245
Registrato il: 27/09/2010
Città: FIRENZE
Età: 61
Utente Veteran
Excel 2010
OFFLINE
06/12/2016 19:53



Ciao,

l'ho fatta troppo semplice. Correggo le formule.

Uso una colonna di servizio

In C2 da copiare accanto al tuo database


=SE(A2="Nome";B2;C1)


In F2 va bene da copiare solo in basso per i nomi

=SE.ERRORE(INDICE($B$1:$B$1000;AGGREGA(15;6;RIF.RIGA($1:$1000)/($A$1:$A$1000=F$1);RIGHE($A$1:$A1)));"")

In G2 da copiare in basso ed a destra

=SE.ERRORE(INDICE($B$1:$B$1000;CONFRONTA($F2&G$1;INDICE($C$1:$C$1000&$A$1:$A$1000;);0));"")

Così dovrebbe andare


Saluti

Post: 7
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
06/12/2016 20:05

Ho corretto questa riga =SE(A2="Nome";B2;C1) mettendo uno spazio al posto del c1 sennò mi riportava sempre lo stesso nome trascinandola giù.
Il resto lo stò testando.

Post: 8
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
06/12/2016 20:06

Al momento mi congedo e ti ringrazio infinitamente. A domani che sicuramente avrò bisogno del tuo aiuto.
GRazie [SM=x423070] [SM=x423070] [SM=x423070]
Post: 2.248
Registrato il: 27/09/2010
Città: FIRENZE
Età: 61
Utente Veteran
Excel 2010
OFFLINE
06/12/2016 20:15



Ciao,

gentilissimo.

Allego il file dove ho fatto le prove

Saluti

Post: 765
Registrato il: 24/04/2004
Città: TERAMO
Età: 63
Utente Senior
2010
OFFLINE
06/12/2016 20:17

Soluzione a "forza bruta"
Public Sub Incolonna2() 
Dim lRiga As LongPtr, rTabella As LongPtr, I As LongPtr, Last As LongPtr 
Dim Elenco As Range, Tabella As Range 
Dim Headers As Variant, nHeaders As Long, pHeader As Long 
'== 
 Headers = Array("Nome", "Nascita:", "Ordine:", "Iscrizione:", "Sezione/Settore:" _ 
 , "Altro:", "E-mail:", "Telefono:", "Fax:", "Indirizzo Studio:") 
 nHeaders = UBound(Headers) + 1 
 Set Elenco = Range("A1") 
 Set Tabella = Range("D1") 
 For I = 1 To nHeaders 
 Tabella(1, I) = Headers(I - 1) 
 Next I 
 rTabella = 1 
 lRiga = 1 
 Last = Cells(Rows.Count, 1).End(xlUp).Row 
 Do While lRiga < Last 
 lRiga = lRiga + 1 
 If Elenco(lRiga, 1) = Headers(0) Then 
 rTabella = rTabella + 1 
 Tabella(rTabella, 1) = Elenco(lRiga, 2) 
 Else 
 pHeader = HPos(Headers, Elenco(lRiga, 1)) 
 If pHeader > 0 Then 
 Tabella(rTabella, pHeader + 1) = Elenco(lRiga, 2) 
 End If 
 End If 
 Loop 
 Set Elenco = Nothing 
 Set Tabella = Nothing 
End Sub 


...anche se un poco in ritardo, vedo. [SM=g27823]
[Modificato da Zer0kelvin 06/12/2016 20:21]
__________________________
[Excel 2010]
-Condividere la conoscenza aumenta la ricchezza di tutti.
-Dai ad un uomo un pesce e lo avrai sfamato per un giorno; insegnagli a pescare e lo avrai sfamato per sempre. (Confucio)
-Il sonno della ragione genera mostri. (Francisco Goya)
Post: 9
Registrato il: 06/12/2016
Città: MILANO
Età: 43
Utente Junior
excel 2013
OFFLINE
07/12/2016 09:30

Ringrazio tutti ma proprio tutti per il supporto che mi avete dato. Grazie [SM=x423028] [SM=x423030]
Post: 3.536
Registrato il: 13/03/2012
Città: LIVORNO
Età: 78
Utente Master
2010
OFFLINE
07/12/2016 09:54

Zer0kelvin, mi sembra interessante il tuo approccio, potresti spiegarlo ? hai dimenticato di allegare la funzione hpos
[Modificato da patel45 07/12/2016 09:59]

----------
Win 10 - Excel 2010
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Post: 768
Registrato il: 24/04/2004
Città: TERAMO
Età: 63
Utente Senior
2010
OFFLINE
08/12/2016 10:36


hai dimenticato di allegare la funzione hpos


Hai ragione, scusatemi.Tra l'altro avevo anche pafsticcciato coi tag CODE.
Private Function HPos(H As Variant, Search As String) As Long
'cerca la stringa Search nell'array H,restituisce l'indice in H
Dim I As Long
    HPos = -1 'se non trovo Searc in H, restituisco un valore di errore
    If Search <> "" Then
        For I = 0 To UBound(H)
            If H(I) = Search Then
                HPos = I
                Exit Function
            End If
        Next I
    End If
End Function

Public Sub Incolonna2()
Dim lRiga As LongPtr, rTabella As LongPtr, I As LongPtr, Last As LongPtr
Dim Elenco As Range, Tabella As Range
Dim Headers As Variant, nHeaders As Long, pHeader As Long
'==
    Headers = Array("Nome", "Nascita:", "Ordine:", "Iscrizione:", "Sezione/Settore:" _
                    , "Altro:", "E-mail:", "Telefono:", "Fax:", "Indirizzo Studio:") 'array che contiene le nostre intestazioni per la tabella
    nHeaders = UBound(Headers) + 1 'il n° delle intestazioni
    Set Elenco = Range("A1")
    Set Tabella = Range("D1")
    For I = 1 To nHeaders 'scrivo le intestazioni
        Tabella(1, I) = Headers(I - 1)
    Next I
    rTabella = 1 'posizione di riga all'interno della tabella
    lRiga = 1 'posizione di riga all'interno dell'elenco
    Last = Cells(Rows.Count, 1).End(xlUp).Row 'ultima riga dell'elenco
    Do While lRiga < Last 'se non siamo a fine elenco
        lRiga = lRiga + 1 'vediamo la riga successiva
        If Elenco(lRiga, 1) = Headers(0) Then 'se trovo la stringa "Nome"
            rTabella = rTabella + 1 'avanzo di una riga nella tabella
            Tabella(rTabella, 1) = Elenco(lRiga, 2) 'scrivo il dato corrispondente
        Else
            pHeader = HPos(Headers, Elenco(lRiga, 1)) 'cerco la colonna della tabella
            If pHeader > 0 Then 'se pHeader=-1 la cella è vuota, il caso pHeader=1(trattato precedentemente) può essere ignorato
                Tabella(rTabella, pHeader + 1) = Elenco(lRiga, 2) 'scrivo il dato in tabella
            End If
        End If
    Loop
    Set Elenco = Nothing
    Set Tabella = Nothing
End Sub
    


**EDIT**
Riguardo il funzionamento, il codice si limita ad usare le voci in colonna A e ne ricava la posizione di colonna relativa alla tabella.
Mi rendo conto che la sintassi usata per i range è un pò insolita, per es:
Tabella(rTabella, pHeader + 1) = Elenco(lRiga, 2)

equivale a scrivere
Tabella.Cells(rTabella, pHeader + 1) = Elenco.Cells(lRiga, 2)

Avrei dovuto commentare il codice, ma consideriamo che:
-a chi non è pratico di VBA i commenti non sarebbero utili [SM=g27825]
-chi è pratico di VBA non ha bisogno dei commenti [SM=g27828]
-sono moooolto PIGRO... [SM=g27835]
Scherzi a parte, avrei dovuto commentare il codice... [SM=x423030]
[Modificato da Zer0kelvin 08/12/2016 11:25]
__________________________
[Excel 2010]
-Condividere la conoscenza aumenta la ricchezza di tutti.
-Dai ad un uomo un pesce e lo avrai sfamato per un giorno; insegnagli a pescare e lo avrai sfamato per sempre. (Confucio)
-Il sonno della ragione genera mostri. (Francisco Goya)
Post: 3.540
Registrato il: 13/03/2012
Città: LIVORNO
Età: 78
Utente Master
2010
OFFLINE
08/12/2016 11:03

funziona perfettamente ed ha il vantaggio di essere universale, basta cambiare gli headers.
[Modificato da patel45 08/12/2016 11:15]

----------
Win 10 - Excel 2010
allega un file di esempio, guadagnerai tempo tu e lo farai risparmiare a chi ti aiuta
Post: 769
Registrato il: 24/04/2004
Città: TERAMO
Età: 63
Utente Senior
2010
OFFLINE
08/12/2016 12:02

Volendo esagerare, si potrebbero passare come parametri diversi dati: Elenco, Tabella, HEaders.
L'importante è che i dati di origine siano in due colonne adiacenti.

Con pochissime modifiche:
Public Sub Incolonna3(ByRef Elenco As Range, ByRef Tabella As Range, Headers As Variant)
Dim lRiga As LongPtr, rTabella As LongPtr, I As LongPtr, Last As LongPtr

Dim nHeaders As Long, pHeader As Long
'==
    nHeaders = UBound(Headers) + 1 'il n° delle intestazioni
    For I = 1 To nHeaders 'scrivo le intestazioni
        Tabella(1, I) = Headers(I - 1)
    Next I
    rTabella = 1 'posizione di riga all'interno della tabella
    lRiga = 1 'posizione di riga all'interno dell'elenco
    Last = Cells(Rows.Count, 1).End(xlUp).Row 'ultima riga dell'elenco
    Do While lRiga < Last 'se non siamo a fine elenco
        lRiga = lRiga + 1 'vediamo la riga successiva
        If Elenco(lRiga, 1) = Headers(0) Then 'se trovo la stringa "Nome"
            rTabella = rTabella + 1 'avanzo di una riga nella tabella
            Tabella(rTabella, 1) = Elenco(lRiga, 2) 'scrivo il dato corrispondente
        Else
            pHeader = HPos(Headers, Elenco(lRiga, 1)) 'cerco la colonna della tabella
            If pHeader > 0 Then 'se pHeader=-1 la cella è vuota, il caso pHeader=1(trattato precedentemente) può essere ignorato
                Tabella(rTabella, pHeader + 1) = Elenco(lRiga, 2) 'scrivo il dato in tabella
            End If
        End If
    Loop
End Sub

Si presume che il primo indice di Headers sia zero.
SP: non testata.
[Modificato da Zer0kelvin 08/12/2016 12:15]
__________________________
[Excel 2010]
-Condividere la conoscenza aumenta la ricchezza di tutti.
-Dai ad un uomo un pesce e lo avrai sfamato per un giorno; insegnagli a pescare e lo avrai sfamato per sempre. (Confucio)
-Il sonno della ragione genera mostri. (Francisco Goya)
Vota:
Amministra Discussione: | Chiudi | Sposta | Cancella | Modifica | Notifica email Pagina precedente | 1 | Pagina successiva
Nuova Discussione
 | 
Rispondi
Cerca nel forum
Tag discussione
Discussioni Simili   [vedi tutte]
Feed | Forum | Bacheca | Album | Utenti | Cerca | Login | Registrati | Amministra
Tutti gli orari sono GMT+01:00. Adesso sono le 14:18. Versione: Stampabile | Mobile | Regolamento | Privacy
FreeForumZone [v.6.1] - Copyright © 2000-2024 FFZ srl - www.freeforumzone.com