macro che faccia il trasponi di una colonna senza copia incolla

Question

Buongiorno,

Vorrei sapere se sia possbile creare una macro che ottenga lo stesso risultato del "trasponi" senza ricorrere al copia/incolla speciale.

In pratica vorrei sapere se sia possibile, mediante macro, assegnare a un vettore orizzontale (una riga) i valori di un vettore verticale (una colonna). So che il modo più semplice è usare delle formule oppure una macro che faccia copia/incolla

tipo:

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=True

Vorrei, però, sapere se sia possibile ottenere lo stesso risultato senza ricorrere al Selection.PasteSpecial

Grazie in anticipo

Answer 1

Ciao Luca,

Mi scusi, Norman: funziona!

Non avevo selezionato la colonna da trasporre ecco il perché dell'errore.

Come scritto, si incontrerebbe un errore se la selezione non fosse un intervallo o se l'intervallo comprendesse solo una cella. La versione del codice qui sotto gestisce entrambe queste possibilità.

Ne approfitto per farle un'altra domanda:

come potrei adattare quella macro affinché il transpose avvenga nella prima riga vuota di una detrminata sheet?

Prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim arrIn As Variant, arrOut() As Variant

    Dim sMsg As String, sTitle As String, ibuttons As Long

    Dim UB As Long, UB2 As Long

    Dim i As Long, j As Long

    Dim LRow As Long

    Const sFoglioDestinazione As String = "Foglio2"       '<<=== Modifica

    If TypeName(Selection) <> "Range" Then

        sMsg = "Non Hai selezionato un intervallo !"

        ibuttons = vbCritical

        sTitle = "CODICE TERMINATO !"

        GoTo XIT

    ElseIf Selection.Cells.Count = 1 Then

        sMsg = "Hai  selezionato solo una singola cella !"

        ibuttons = vbCritical

        sTitle = "CODICE TERMINATO !"

        GoTo XIT

    End If

    Set WB = ThisWorkbook

    Set srcRng = Selection

    Set destSH = WB.Sheets(sFoglioDestinazione)

    With destSH

        LRow = LastRow(destSH, .Columns("A:A"))

        Set destRng = destSH.Range("A" & LRow + 1)

    End With

    arrIn = srcRng.Value

    UB = UBound(arrIn)

    UB2 = UBound(arrIn, 2)

    ReDim arrOut(1 To UB2, 1 To UB)

    For i = 1 To UB

        For j = 1 To UB2

            arrOut(j, i) = arrIn(i, j)

        Next j

    Next i

    destRng.Resize(UB2, UB).Value = arrOut

    Exit Sub

XIT:

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=ibuttons, _

         Title:=sTitle)

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    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

End Function

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

===

Regards,

Norman

Answer 2

Ciao Luca,

Molte Grazie Norman,

Funziona perfettamente!

Ti ringrazio per il cortese riscontro.

Per chiudere questo thread, vorrei chiederti gentilmente di contrassegnare la mia risposta come Risposta preferita. In questo modo, tu aiuterai anche coloro che potessero cercare soluzioni ai problemi simili negli archivi della Community.

  

===

Regards,

Norman

Answer 3

Ciao Luca,

Vorrei sapere se sia possbile creare una macro che ottenga lo stesso risultato del "trasponi" senza ricorrere al copia/incolla speciale.

In pratica vorrei sapere se sia possibile, mediante macro, assegnare a un vettore orizzontale (una riga) i valori di un vettore verticale (una colonna). So che il modo più semplice è usare delle formule oppure una macro che faccia copia/incolla

tipo:

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=True

Vorrei, però, sapere se sia possibile ottenere lo stesso risultato senza ricorrere al Selection.PasteSpecial

Certo! Per gestire una qualunqe selezione di righe e\o colonne, prova la seguente procedura:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim srcRng As Range

    Dim arrIn As Variant, arrOut() As Variant

    Dim UB As Long, UB2 As Long

    Dim i As Long, j As Long

    Set srcRng = Selection

    arrIn = srcRng.Value

    UB = UBound(arrIn)

    UB2 = UBound(arrIn, 2)

    ReDim arrOut(1 To UB2, 1 To UB)

    For i = 1 To UB

        For j = 1 To UB2

            arrOut(j, i) = arrIn(i, j)

        Next j

    Next i

    With srcRng

        .ClearContents

        .Cells(1).Resize(UB2, UB).Value = arrOut

    End With

End Sub

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

===

Regards,

Norman

Answer 4

Mi scusi, Norman: funziona!

Non avevo selezionato la colonna da trasporre ecco il perché dell'errore.

Ne approfitto per farle un'altra domanda:

come potrei adattare quella macro affinché il transpose avvenga nella prima riga vuota di una detrminata sheet?

Ancora grazie dell'interessamento

Answer 5

Gentile Norman,

Grazie della risposta ma non va.

Eseguendo il Tester mi da errore:

Errore di run-time 13

Tipo non corrispondente

Dal debug, l'errore risulterebbe essere qui:

UB = UBound(arrIn)

Aspetto una sua risposta, ancora grazie