XL 2016 macro VBA, passer d'une structure à une autre

medmed94

XLDnaute Nouveau
Bonjour,

J'aimerai concevoir une macros qui prend chaque lignes du tableau et les transformes en une seule colonne, en les imbriquant en structure ABAB.

Si vous avez des pistes ?

Cordialement,
 

Staple1600

XLDnaute Barbatruc
Bonjour

Voici un e macro qui devrait convenir
(Désolé de ne pas avoir pu répondre plus tôt)
Code:
Sub Macro_Urgente()
With Application
.ScreenUpdating = False
Range("A:C").Clear
Range("A1:B" & .RandBetween(16, 1600)) = Array(Chr(65) & Chr(66), Chr(66) & Chr(65))
Range("C1").Resize(Cells(Rows.Count, 1).End(3).Row) = "=A1&B1"
Range("A1").CurrentRegion.Borders.LineStyle = 1
.ScreenUpdating = True
End With
End Sub
 

eriiiic

XLDnaute Barbatruc
Bonjour,

tu charries Staple, c'était urgent...

medmed94, il faut éviter ces mots dans les titres, ça fait plutôt fuir.
Eviter aussi les 'aidez-moi' etc, mettre un titre en rapport avec la question.
Si tous les topics sont titrés Urgent ou Aidez-moi, lequel tu ouvres après une recherche ?
eric
 

medmed94

XLDnaute Nouveau
Bonjour,

merci pour tout vos messages, je suis d'accord avec toi eriiiic pour le titre, au temps pour moi.

je te remercie pour la macros Staple1600, je me suis mal exprimer concernant cette dernière.
je met un fichier join pour expliquer au mieux ma demande.
je part de la structure de la feuille1 pour arriver à la structure de la feuille, en utilisant une macros.

cordialement.
 

Fichiers joints

Staple1600

XLDnaute Barbatruc
Bonsoir


Une macro en hommage à Richard Dean Anderson ;)
(A lancer quand on est sur la feuille 1 du classeur exemple)
VB:
Sub MacGyver_Angus()
Dim lig&, f$
f = "=IF(OFFSET(R1C1,(ROWS(R[-1]C[-1]:R1C[-1])-1)*10+COLUMNS(C1:C[-1])-1,)=0,"""",OFFSET(R1C1,(ROWS(R[-1]C[-1]:R1C[-1])-1)*10+COLUMNS(C1:C[-1])-1,))"
lig = Cells(Rows.Count, 1).End(3).Row
With Range("B2:K" & lig)
.FormulaR1C1 = f: .Value = .Value
End With
Range("B:B,D:D,F:F,H:H,J:J").Delete Shift:=xlToLeft: Range("F2:F" & lig).NumberFormat = "m/d/yyyy"
Range("B1:F1") = Array("Couleurs", "Nom", "Prénom", "Age", "Date de naissance")
End Sub
 

medmed94

XLDnaute Nouveau
Bonsoir,

merci infiniment pour la macros, mais elle ne fonctionne pas correctement quand je la lance elle me supprime les données de la feuille 1 et ne m'écrit rien dans la feuille 2 les données disparaissent.
j'aimerai que la macros part de la structure de la feuille 1 pour a l'arrivé j'obtiens la feuille 2 comme dans mon exemple .
Dans la macros que tu ma envoyés il me supprime des données et me mélange au niveau des colonnes.

cordialement,

merci pour le travail que tu as fait .
 
Dernière édition:

medmed94

XLDnaute Nouveau
j'aimerai que l'affichage soit sur la colonne A et non en ligne comme dans la feuille 2 que j'ai mis en exemple car ici les données s'affiche en ligne et il n'y a pas toute les données qui sont recopié. mais ta macros fonctionne super.
 

Staple1600

XLDnaute Barbatruc
Re

Avec celle-ci, il y a du mieux, mais c'est pas encore ça, hein ? ;)
Code:
Sub Test_2()
Dim Source As Range, c As Range, lig&, i&
lig = Feuil1.Cells(Rows.Count, 1).End(3).Row
Set Source = Feuil1.Range("A2:E" & lig)
i = 0
Application.ScreenUpdating = False
For Each c In Source.Rows
c.Copy
Feuil2.[A1].Offset(i, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
i = i + c.Columns.Count
Next
End Sub
PS: Vider la feuille 2 avant de lancer la macro.
 

medmed94

XLDnaute Nouveau
ah oui carrément mieux sa marche super et dit moi si je veux rajouter des information sur quoi je dois jouer ?
 

medmed94

XLDnaute Nouveau
frenchement chapeau tu as fait un travail magnifique !

j'aimerai savoir s'il est possible d'inscrire les information en colonne B par exemple et le nom des entêtes en colonne A ?
 

Staple1600

XLDnaute Barbatruc
Re

Avec cette version, c'est ok ?
VB:
Sub Test_3()
Dim Source As Range, c As Range, lig&, i&
vEnt = Array("Couleurs", "Nom", "Prénom", "Age", "Date de naissance")
lig = Feuil1.Cells(Rows.Count, 1).End(3).Row
Set Source = Feuil1.Range("A2:E" & lig)
i = 0
Application.ScreenUpdating = False
For Each c In Source.Rows
c.Copy
Feuil2.[A1].Offset(i, 0).Resize(5) = Application.Transpose(vEnt)
Feuil2.[A1].Offset(i, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
i = i + c.Columns.Count
Next
Feuil2.Columns("A:B").Columns.AutoFit: Feuil2.[A1].CurrentRegion.Borders.LineStyle = 1
End Sub
 

Discussions similaires


Haut Bas