trasposizione da colonna a riga

[Gianca532011]

ciao, eccomi ancora qui con, spero, un piccolo problemino del quale non riesco a venirne a capo.
Come da titolo ho una colonna excell contenente 20 dati ( testo+ valori, ma non formule) nel range A1:A20 e li devo trasporre in righe successive a partire dalla C1. I dati che ho nella colonna A sono sempre 20 righe e li sostituisco ogni volta .
Ho trovato questa macro che funziona bene nel senso della trasposizione ma non mi fa l'accodamento successivo verso il basso , ovvero se C1..<>0, vai a C2 etc.
Dubbio : ma essendo stringhe non è che <> non funzioni , ovvero richieda un valore numerico ? Boh .
comunque ecco qua il codice .

Codice: Seleziona tutto

Sub DaColonnaATabella()
'Copia i dati da ColannaBase in una tabella a fianco di quaranta colonne
Dim ColonnaBase As Integer, RigaIniziale As Integer, RigaFinale As Integer
Dim Riga As Integer, Colonna As Integer, RigaDestinazione As Integer
Dim ColonnaDestinazione As Integer, r As Integer, c As Integer, nColonne As Integer
 
    ColonnaBase = 1      'presuppone i dati siano in colonna A, eventualmente cambiare
    RigaIniziale = 1     'presuppone i dati partano da riga 1, eventualmente cambiare
    RigaDestinazione = 1 'presuppone i dati vengano incollati a partire da riga 1,
                         'eventualmente cambiare
    ColonnaDestinazione = 3 'presuppone i dati vengano incollati a partire da colonna 3
                         'eventualmente cambiare
    nColonne = 20        'numero di colonne nella tabella di destinazione
     
    Riga = RigaIniziale
    r = RigaDestinazione   
    RigaFinale = Cells(Cells.Rows.Count, ColonnaBase).End(xlUp).Row
    Do While Riga <= RigaFinale
        For c = ColonnaDestinazione To (ColonnaDestinazione + nColonne - 1)
            Cells(r, c) = Cells(Riga, ColonnaBase)   
            Riga = Riga + 1
        Next
        r = r + 1
    Loop
End Sub

[wallace&gromit]

Ciao, non sono sicuro di avere capito le tue necessità, ma penso che la parte " r = r + 1" debba andare prima del "Next".

Il risultato sono scritte che si distribuiscono in diagonale scendendo fino alla cella V20, e poi riprendono dalla C21, è quello che vuoi?

[Gianca532011]

No, in orizzontale , per righe successive, ovvero : primo set da colonna 1 a riga 1 , secondo set da colonna 1 a riga 2 etc.

[Marius44]

Ciao Gianca
spero di aver individuato il tuo problema. Nella tua macro effettua le seguenti operazioni:

r = RigaDestinazione ===> riga da eliminare

Dopo Do While
r = Cells(Rows.Count, 3).End(xlUp).Row + 1 ===> riga da aggiungere

Prima di Loop
r = r + 1 ===> riga da eliminare

In poche parole la tua macro diventa questa:

Codice: Seleziona tutto

Sub DaColonnaATabella()
'Copia i dati da ColannaBase in una tabella a fianco di quaranta colonne
Dim ColonnaBase As Integer, RigaIniziale As Integer, RigaFinale As Integer
Dim Riga As Integer, Colonna As Integer, RigaDestinazione As Integer
Dim ColonnaDestinazione As Integer, r As Integer, c As Integer, nColonne As Integer
 
    ColonnaBase = 1      'presuppone i dati siano in colonna A, eventualmente cambiare
    RigaIniziale = 1     'presuppone i dati partano da riga 1, eventualmente cambiare
    RigaDestinazione = 1 'presuppone i dati vengano incollati a partire da riga 1,
                         'eventualmente cambiare
    ColonnaDestinazione = 3 'presuppone i dati vengano incollati a partire da colonna 3
                         'eventualmente cambiare
    nColonne = 20        'numero di colonne nella tabella di destinazione
     
    Riga = RigaIniziale
    RigaFinale = Cells(Cells.Rows.Count, ColonnaBase).End(xlUp).Row
    Do While Riga <= RigaFinale
        r = Cells(Rows.Count, 3).End(xlUp).Row + 1
        For c = ColonnaDestinazione To (ColonnaDestinazione + nColonne - 1)
            Cells(r, c) = Cells(Riga, ColonnaBase)
            Riga = Riga + 1
        Next
    Loop
End Sub


Ovviamente prova e fai sapere. Ciao,
Mario

[Anthony47]

Ciao a tutti.
Non ho dubbi che la macro pubblicata da Mario funzioni regolarmente; mi chiedo pero' il motivo della complicazione della macro iniziale...
Da quel che ho capito dovrebbe essere sufficiente:

Codice: Seleziona tutto

Sub Colonna2Tabella()
Dim myRan As Range, myDest As Range
'
Set myRan = Range("A1:A20")     '<<< L'area che viene copiata
Set myDest = Range("C1")        '<<< La cella top-left dove si incolla
myRan.Copy
myDest.Offset(1000, 0).End(xlUp).Offset(1, 0).PasteSpecial _
    Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
End Sub


Le istruzioni marcate <<< vanno eventualmente modificate come da commento

[Gianca532011]

Grazie, sono entrambe impeccabili, oltre che funzionali. Alla fine ci sono riuscito anch'io ,ma la macro che ne è uscita , prelevata un po' qua e un po' là è mostruosa a confronto.
il guaio però, sebbene funzioni bene, è che tecnicamente non ci ho capito una mazza, ho solo assemblato il costrutto di altri. Cosi non imparerò mai, ma d'altronde ricominciare dall'abc e poi subito dimenticare per mancanza di esercizio ? ne vale la pena

Allego la " bestia" , unica differenza che traspone in foglio 2 e qui accoda .

Codice: Seleziona tutto

Public shUltimoFoglio As Worksheet

' la ex variabile shF2 si chiama ora shUltimoFoglio, viene impostata dopo la chiamata della funzione fnFineCol
' la dichiarazione Public serve a condividere la variabile.

Sub Trasponi()

Dim Riga As Long
Dim Colonna As Long
Dim shF1 As Worksheet

Set shF1 = Worksheets("Foglio1")

Riga = 2
Colonna = fnFineCol(Riga)

shF1.Select
Range("A1:A20").Select
Selection.Copy
shUltimoFoglio.Select
Cells(Riga, Colonna).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range("A1:A20").ClearContents
Call incolla
End Sub

Function fnFineCol(Riga As Long) As Long

Dim Colonna As Long
Dim Indice As Integer

' il valore 255 lo devi impostare pari al numero di cartelle del tuo foglio di lavoro
For Indice = 2 To 255
Set shUltimoFoglio = Worksheets("Foglio" & Indice)
For Colonna = 1 To 250
If shUltimoFoglio.Cells(Riga, Colonna) = "" Then
fnFineCol = Colonna
Exit Function
End If
Next Colonna
Next Indice

End Function


Sub incolla()

   Dim PrimaRigaUtileDelFoglio2 As Long
   'determinazione della prima riga vuota nel foglio2
   PrimaRigaUtileDelFoglio2 = Foglio2.Cells(Foglio2.Rows.Count, 2).End(xlUp).Row + 1
   
   '  copia il range nel foglio2
   Sheets("Foglio2").Range("A2:U2").Copy
   
   ' Incollalo nel range del foglio3
   Sheets("Foglio2").Range("A" & PrimaRigaUtileDelFoglio2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
   
   ' togli la selezione tratteggiata
   Application.CutCopyMode = False
   
   ' PArtendo dal basso controlli che tutte le righe e se sono vuote le elimini
   ' Ridetermini l' ultima riga
   PrimaRigaUtileDelFoglio2 = Foglio2.Cells(Foglio2.Rows.Count, 1).End(xlUp).Row
   ' e poi le cicli tutte ALLA ROVESCIO ed elimini le vuote:
   '
   ' Per tutte le righe che vanno dalla prima riga utile del foglio3 fino alla riga "B2" facendo passi all' indietro (-1)
   Dim ciclo As Long
   For ciclo = PrimaRigaUtileDelFoglio2 To Range("A2").Row Step -1
      'SE la cella della riga in esame, nella colonna "B" è vuota ALLORA
      If Foglio2.Cells(ciclo, 2).Value = "" Then
         'CAncella TUTTA la riga della cella in esame
         Foglio3.Cells(ciclo, 2).EntireRow.Delete
      End If
   Next
   'seleziona la cella "A1" del foglio3
   Foglio2.Select
   Foglio2.Cells(1, 1).Select
Call Macro1
End Sub

Sub Macro1()
   
    Sheets("Foglio1").Select
    Range("A1:A20").Select
    Selection.ClearContents
End Sub



la macro principale "trasponi" l'ho agganciata a un pulsante inserito su foglio 1

[Anthony47]

Perdona, ma se "sono entrambe impeccabili, oltre che funzionali" allora dovresti studiare quelle due, che sono 5-10 volte piu' semplici di quanto hai articolato.
A meno che non funzioni niente e non hai il coraggio di dircelo! Che pero' e' il metodo migliore per non imparare niente.

Quanto al mio codice, se vuoi trasporre in un foglio diverso da quello di origine allora devi modificare i due Set iniziali; esempio:

Codice: Seleziona tutto

Set myRan = Sheets("Foglio11").Range("A1:A20")     '<<< L'area che viene copiata
Set myDest = Sheets("Foglio33").Range("C1")        '<<< L'area dove si comincia a incollare

Ciao

[Gianca532011]

Ciao e grazie, inutile dire che la tua macro funziona ed è anche semplice da capire, ora però ti aggiungo una complicazione , ovvero se volessi copiare diversi set di dati, sempre di 20 righe + spazi vuoti tra un set e l'altro , disposti sempre in colonna a partire da a1 , devo fare un ciclo for oppure ?

[Gianca532011]

Ho aggiunto un ciclo for e funziona ni, ovvero copia , accoda ma non fa il reset del next, ovvero copia x 10 volte le 20 righe MA sempre da 1 a 20, cioè ripete la stessa sequenza in pratica non mi fa il next+20 . Cosa mi sono perso ?

Codice: Seleziona tutto

Sub Colonna2Tabella()
Dim myRan As Range, myDest As Range
Set myRan = Sheets("Foglio1").Range("A1:A20")     '<<< L'area che viene copiata
For Ciclo = 1 To 10 ' <<questo mi è utile perche poi posso cancellare 10 x 20 righe
RigaInizio = (Ciclo - 1) * 20 + 1
RigaFine = Ciclo * 20
MsgBox RigaInizio & " " & RigaFine
Set myDest = Sheets("Foglio2").Range("A2")        '<<< L'area dove si comincia a incollare
myRan.Copy
myDest.Offset(1000, 0).End(xlUp).Offset(1, 0).PasteSpecial _
    Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Next Ciclo
End Sub


[Anthony47]

Tra le tante possibilita':

Codice: Seleziona tutto

Sub Colonna2Tabella22()
Dim myRan As Range, myDest As Range
'
Set myRan = Sheets("Foglio2").Range("A1")       '<<< L'inizio dell'area che viene copiata
Set myDest = Sheets("Foglio3").Range("C1")      '<<< L'area dove si comincia a incollare
mylungh = 20                                    '<<< Le righe da copiare
mybreak = 1                                     '<<< Le righe vuote tra un blocco e l'altro
For i = 1 To 10
    myRan.Offset((mylungh + mybreak) * (i - 1), 0).Resize(mylungh, 1).Copy
    myDest.Offset(10000, 0).End(xlUp).Offset(1, 0).PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
Next i
End Sub


Nota l'uso di Offset e Resize per determinare quale area copiare.

Un'altra opzione potrebbe essere quella di copiare e trasporre il primo blocco (lunghezza variabile), poi copiare il secondo blocco (indipendentemente dal numero di spazi vuoti), e cosi' via fintanto che c'e' un "blocco" da copiare. Per blocco intendo un gruppo di celle contigue contenenti valori (non formule).

Ciao

[Gianca532011]

Grazie Anthony : è perfetta ma non avevo dubbi in merito.
Quando vuoi potresti passarmi anche la trasposizione a blocchi di cui mi accennavi nel tuo post precedente , ti confesso che ci ho provato anch'io ma , ovviamente senza risultati validi.
Ancora grazie .

[Anthony47]

Ad esempio:

Codice: Seleziona tutto

Sub Colonna2Tabella33()
'vedi http://www.pc-facile.com/forum/viewtopic.php?f=26&t=107316
Dim myRan As Range, myDest As Range, mrC As Long, LastR As Long, LastBlk As Long
'
Set myRan = Sheets("Foglio2").Range("C1")       '<<< L'inizio dell'area che viene copiata
Set myDest = Sheets("Foglio3").Range("C1")      '<<< L'area dove si comincia a incollare
'
Application.Goto myRan
Set myRan = Selection.Cells(1, 1)
mrC = myRan.Column: LastR = Cells(Rows.Count, mrC).End(xlUp).Row + 1
Do
    LastBlk = Evaluate("min(if(" & myRan.Resize(100, 1).Address & "="""",row(" & myRan.Resize(100, 1).Address & "),""""))")
    If LastBlk > LastR Then Exit Do
    Range(myRan, Cells(LastBlk, mrC)).Copy
    myDest.Offset(10000, 0).End(xlUp).Offset(1, 0).PasteSpecial _
        Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    Set myRan = Cells(LastBlk + 1, mrC)
Loop
End Sub


Questa copia ogni blocco che trova verso il basso di myRan; ogni blocco finisce al primo vuoto trovato; il blocco puo' essere anche di 1 sola cella.

Ciao

[Gianca532011]

Grazie Anthony, la tua macro è impeccabile come sempre.

[Gianca532011]

Ciao, ho aggiunto un altro foglio ed ho l'esigenza di copiare da una cella in un'altra del nuovo foglio, fin qui banale, ma ... con la macro da me creata ottengo che l'accodamento avviene ma con spostamento - laterale - sono bravo no , peccato che NON è il risultato voluto !
Chiarisco : da "foglio 2" devo copiare dalla colonna B2 al nuovo foglio "prezzi" nella colonna A2 . I dati si aggiornano per effetto della macro precedente (vedi due post sopra) con trasposizione . In sostanza devo prelevare l'ultimo dato da fo2 e copiarlo nella prima riga vuota della colonna A2 di prezzi.
Ho provato con :

Codice: Seleziona tutto

Sub Copia1()

Dim myA As Range, myDA As Range

Set myDA = Sheets("Foglio2").Cells("2,2")      '<<< L'area di origine
Set myA = Sheets("Prezzi").Range("A2")      '<<<< Indicare la colonna in cui copiare

Set myDA = Selection.Cells(1, 2)      '<<< (copia isin ) inizio area che viene copiata
Selection.Copy  ' range da cui copiare
Sheets("Prezzi").Select
Set myA = Selection.Cells(1, 2)
myA.Offset(1000, 0).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

End Sub

[Anthony47]

Non ho capito...
Vuoi copiare l'ultimo dato presente in Foglio2 - colonna B e accodarlo nella prima cella libera di Prezzi - colonna A, dove Foglio2-colonna B e' impostato in myDest?
Se Si, allora in coda al codice precedente aggiungi

Codice: Seleziona tutto

myDest.Offset(10000,0).End(xlup).Copy Sheets("Prezzi").cells(Rows.count,1).end(xlup).Offset(1,0)


Ciao

[Gianca532011]

Grazie, soparttutto per non aver commentato il mio tentativo di codice ... ciao

[Anthony47]

Ah ah... Che vuoi, cerco di evitare le missions impossible, ma mi hai smascherato

[Gianca532011]

Eccomi di nuovo con un altro quesito che pubblico qui in quanto estensione del precedente lavoro.

Vorrei trasportare i dati di un foglio excel in formato grafico, e fin qui ci sono riuscito scopiazzando una macro trovato sul forum, funziona perfettamente ma eccoti la complicanza : se nella mia tabella di origine ho 100-200 righe , come faccio a copiare blocchi di 32 righe ( ovvero tali da essere leggibili) in fogli successivi ? devo creare un ciclo for o che altro?
questo la macro adattata:

Codice: Seleziona tutto

Private Sub Pulsante4_Click()
'
MySheet = "Foglio2"     '<<< Il foglio da "fotografare"
MyArea = "A1:j32"       '<<< La tua area da fotografare
'
'Nominat = Sheets("Foglio2").Range("A1").Value  '<<< La cella dove si trova il nominativo "emittente"
'
Sheets(MySheet).Activate
Range(MyArea).Select
GifLargh = Selection.Width + 10         '<<<AGGIUNTA
GifAlt = Selection.Height + 10             '<<<AGGIUNTA
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Sheets("Scratch").Select
Dim ch As ChartObject
Set ch = Sheets("Scratch").ChartObjects.Add(1, 1, GifLargh, GifAlt)
Sheets("Scratch").ChartObjects(1).Activate
ActiveChart.ChartArea.Select
ActiveChart.Paste
OutFile = "C:\prova\" & Nominat & "_ScrSh.jpg"
Worksheets("Scratch").ChartObjects(1) _
.Chart.Export _
Filename:=OutFile, FilterName:="JPEG"
ActiveSheet.ChartObjects(1).Delete
End Sub

[Anthony47]

Ad esempio:

Codice: Seleziona tutto

Private Sub Pulsante4_Click()
'
MySheet = "Foglio3"     '<<< Il foglio da "fotografare"
myArea = "A1:j100"       '<<< La tua area da fotografare
'
For i = 1 To Range(myArea).Rows.Count Step 32
    Sheets(MySheet).Activate
    Cells(i, 1).Resize(32, Range(myArea).Columns.Count).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Sheets.Add After:=Sheets(Sheets.Count)
    Range("A1").Select
    ActiveSheet.Paste
Next i
End Sub

Ciao

[Gianca532011]

Grazie Anthony ,
anche se devo rettificare quanto sopra scritto ovvero quando dico

"copiare blocchi di 32 righe ( ovvero tali da essere leggibili) in fogli successivi

per fogli non intendevo fogli excel ma fogli JPG , cioè un foglio unico in formato immagine con interruzione di pagina ogni 32 righe ( con riporto della riga di intestazione a ogni nuova pagina) successivi l'un l'altro sino a esaurimento delle righe scritte nel foglio2 di excel . Attualmente ottengo si un foglio unico in formato Jpg ma per leggerlo devo zoomare e mi perdo l'intestazione.