XL 2019 URGENT COVID 19 - Macro Transpose

  • Initiateur de la discussion Initiateur de la discussion Ternoise
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Ternoise

XLDnaute Occasionnel
Bonjour à tous
Afin de contacter mes patients rapidement, j'ai besoin d'une macro pouvant faire ceci :
Transposer toutes les 4 lignes dans 4 colonnes différentes

A1 : Nom
A2 : Adresse
A3 : VILLE
A4 : Tel
A5 : Nom
A6 : Adresse
A7 : VILLE
A8 : Tel

etc jusqu'a 11 000 lignes

Transposer dans une nouvelle feuille

Colonne A : les noms
Colonne B : les adresses
Colonne C : les villes
Colonne D : les Tel

Merci de votre aide
David
 
Re, Bonjour chris

Dans la série :"Sortez-moi de VBE!"
(bah, oui à force, on ne s'arrête plus)
Saleté de confinement 😉
VB:
Sub test_P4()
'pas de 4 (par défaut)
TranZp0ZiT0r ActiveSheet.Cells(1), Sheets(2).Cells(1)
End Sub
Sub test_P6()
'pas de 6
TranZp0ZiT0r ActiveSheet.Cells(1), Sheets(2).Cells(1), 6
End Sub
Private Sub TranZp0ZiT0r(RngS As Range, RngD As Range, Optional Pas As Long = 4)
Dim vArr, t(), i&, n&
n = RngS.Cells(Rows.Count, 1).End(3).Row
vArr = RngS.Cells(1).Resize(n)
ReDim t(1 To Int(n / Pas) + 1, 1 To Pas)
For i = 1 To n
    t(1 + Int((i - 1) / Pas), 1 + (i - 1) Mod Pas) = vArr(i, 1)
Next i
RngD.Resize(Int(n / Pas) + 1, Pas) = t
End Sub
 
Bonjour jmfmarques, chris,

On n'est pas obligé de supprimer les formules :
Code:
Private Sub Worksheet_Activate()
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2].Resize(Application.Ceiling(Application.CountA(Sheets("Liste").Columns(1)), 4) / 4, 4)
    .Formula = "=INDEX(Liste!$A:$A,COLUMN()+4*(ROW()-2))"
    .Offset(.Rows.Count).Resize(Rows.Count - .Rows.Count - .Row).ClearContents 'RAZ en dessous
End With
End Sub
Avec 1 000 000 de lignes dans la 1ère feuille elle s'exécute en 1,6 seconde chez moi.

Contre 2,4 secondes avec les tableaux VBA de mapomme et JM.
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
3
Affichages
548
Réponses
10
Affichages
555
Réponses
10
Affichages
836
Réponses
4
Affichages
1 K
Retour