XL 2019 Transposer avec espace

[Arnaud59000]

Bonjour tout le monde,

Petite question du jour, je souhaiterai mettre en colonne des lignes avec un espace de 1 colonne entre chaque colonne.

J'ai bien essayé de me chercher ma solution ne fonctionne pas du tout :

Sub transposetest()

Dim i As Integer
Dim NL As Range

i = 1
NL = Range("A1:A100").Value

While i < NL

Range(1, (2 * i)).Value = Range(i, 1).Value
Range(1, (2 * i + 1)).Value = "PU"

i = i + 1



Wend

End Sub

Avec dans la colonne entre deux lignes transposée, l'inscription "PU"
En PJ un fichier test, merci d'avance

 

[Arnaud59000]

J'ai réussi a transposer avec ce code :

Sub transpose_to_another_sheet()

Dim og As Worksheet
Dim ns As Worksheet
Dim count_col As Integer
Dim count_row As Integer



Set og = ThisWorkbook.Sheets("Info")
Set ns = ThisWorkbook.Sheets("Analyse")

ns.Cells.ClearContents
og.Activate

count_col = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
count_row = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))

For i = 1 To count_col
For j = 1 To count_row


ns.Cells(i, j) = og.Cells(j, i).Text

Next j


Next i

ns.Activate

End Sub

Mais pas moyen d'insérer une colonne sur deux avec l'info souhaitée

 

[vgendron]

Bonjour
essaie avec cette boucle

    For j = 1 To count_row
        ns.Cells(i, 2 * (j - 1) + 1) = og.Cells(j, i).Text
    Next j

 

[Jacky67]

J'ai réussi a transposer avec ce code :




Mais pas moyen d'insérer une colonne sur deux avec l'info souhaitée

Bonjour,
Essaye comme ceci
Dans l'exemple les données à transposer commencent en A1

Sub transposetest()
Dim i&
    With Feuil1
         Application.ScreenUpdating = False
        .Range("a1:a" & .Cells(.Rows.Count, "A").End(xlUp).Row).Copy
        .[c2].PasteSpecial , Transpose:=True
        For i = .Cells("2", .Columns.Count).End(1).Column + 1 To 4 Step -1
            .Columns(i).Insert: .Cells(2, i) = "PU"
        Next
    End With
End Sub

 

[mapomme]

Bonsoir à tous,

Un autre code (dans Module1). Cliquer sur le bouton Hop!

Sub transp()
Dim t, v, i&, n&
   t = Range("a12:a" & Cells(Rows.Count, "a").End(xlUp).Row)
   ReDim v(1 To 1, 1 To 2 * UBound(t)): n = 1
   For i = 1 To UBound(t): v(1, n) = t(i, 1): v(1, n + 1) = "PU": n = n + 2: Next
   With Range("C2")
      Range(.Cells(1, 1), .End(xlToRight)).ClearContents
      If UBound(v, 2) + .Column - 1 > Columns.Count Then
         MsgBox "Trop d'éléments pour la transposition en " & .Address(0, 0) & " => Echec !", vbCritical
      Else
         .Resize(UBound(v), UBound(v, 2)) = v
      End If
   End With
End Sub

 

[Arnaud59000]

Merci tout le monde toutes vos solutions fonctionnent !