Des colonnes en lignes.. mais par paire

flomag

XLDnaute Nouveau
Bonjour à tous,

Je me permets de vous soumettre une demande, j'aimerai mettre toutes les colonnes après B en dessous des lignes A & B mais en le faisant par paire ex :

A B
C D
E F
G H
.....

Pensez-vous que cela est possible ?

Je vous mets 2 screenshots pour mieux visualiser le besoin :

Fichier de départ :

1030714


A ceci:

1030715


Dans l'attente de vous lire,

Merci pour votre aide,

Bien à vous,
 

mapomme

XLDnaute Barbatruc
Re @flomag,

Voir le fichier joint en retour. Cliquez sur le bouton Hop!
Le résultat est sur la feuille "Res".
Le code VBA se trouve dans le Module1:
VB:
Sub ventiler()
Dim t, i&, j&, n&
t = Sheets("data").Range("a1").CurrentRegion
ReDim r(1 To UBound(t) * UBound(t, 2) / 2 + 1, 1 To 3)
For j = 1 To UBound(t, 2) Step 2
  For i = 2 To UBound(t)
    If t(i, j) <> "" Then
      n = n + 1: r(n, 1) = t(1, j)
      r(n, 2) = t(i, j): r(n, 3) = t(i, j + 1)
    End If
  Next i
Next j
With Sheets("Res").Range("a1")
  .Clear
  .Resize(UBound(r), UBound(r, 2)) = r
End With
End Sub
 

Fichiers joints

flomag

XLDnaute Nouveau
Re @flomag,

Voir le fichier joint en retour. Cliquez sur le bouton Hop!
Le résultat est sur la feuille "Res".
Le code VBA se trouve dans le Module1:
VB:
Sub ventiler()
Dim t, i&, j&, n&
t = Sheets("data").Range("a1").CurrentRegion
ReDim r(1 To UBound(t) * UBound(t, 2) / 2 + 1, 1 To 3)
For j = 1 To UBound(t, 2) Step 2
  For i = 2 To UBound(t)
    If t(i, j) <> "" Then
      n = n + 1: r(n, 1) = t(1, j)
      r(n, 2) = t(i, j): r(n, 3) = t(i, j + 1)
    End If
  Next i
Next j
With Sheets("Res").Range("a1")
  .Clear
  .Resize(UBound(r), UBound(r, 2)) = r
End With
End Sub
Super ça marche !!

Merci bcp bcp :)

A bientôt :)
 

Discussions similaires


Haut Bas