Transposer par trois groupes à la fois verticalement
Bonjour à tous,
Dans l’impossibilité de trouver une solution à mon problème, je m’adresse aux experts parmi vous en espérant une aide précieuse.
Je vous explique le problème.
J’ai des données dans les 3 colonnes suivantes : "AH", "AI" et "AJ" à partir de la 3e ligne.
Pour apporter une solution à mon problème, je penses qu’il serait souhaitable de distinguer les divers groupes qui se trouvent dans ces trois colonnes, pour trouver ces divers groupes, on va se baser sur le contenu des cellules de la colonne "AH", c’est-à-dire que chaque groupe doit se composer de toutes les cellules identiques qui se trouvent dans la colonne "AH".
Pour plus de visibilité, j’ai coloriées les groupes avec des couleurs différentes dans la feuille "Nouveaux couples".
Lorsque les groupes sont repérés, je souhaite les transférer par groupes de trois dans les colonnes suivantes , ("AL: AN"), ("AP:AR"), ("AT:AN"), ("AX:AZ"), ("BB:BD"), ("BF:BH") et ("BJ:BL"), en prenant soin de laisser une ligne vide (Horizontalement) entre chaque groupe et aussi laisser une colonne vide (Verticalement) entre les groupes.
Attention : les données se trouvent en partir de la ligne numéro 3 voir la feuille "Résulat souhaité" dans le fichier joint.
La position de la ligne vide horizontale dépend du nombre de lignes qui composent un groupe.
Les colonnes qui reste vides sont : ("AK"), ("AO"), ("AS"), ("AW"), ("BA"), ("BE"), ("BI"),
Sauf erreur de ma part, j’ai mis le résultat souhaité avec les groupes colorés pour mieux vous illustrer le résultat final, mais ne devez à aucun moment mettre les groupes en couleur.
Je reste à votre disposition pour d’autres informations supplémentaires au besoin.
D’avance merci pour vos contributions.
Re,
J’ai oublié de préciser une solution en vba s’il vous plait. Merci
bonjour Harzer,
Sub m_Harzer()
Dim c, Ar, i, i1
Application.ScreenUpdating = False
With Sheets("nouveaux couples")
On Error Resume Next
.AutoFilter.Range.AutoFilter 'désactiver autofiltre eventuel
On Error GoTo 0
Set c = Sheets("résulat souhaité").Cells(3, "AL") 'premiere cellule de résultat
ptr = 0 'compteur vertical
c.Resize(100, 100).ClearContents 'RAZ plage suffisant grande
With .Range("AH2") 'cellule juste au dessus données
If .Value = "" Then .Value = " " 'si vide, mettre un espace dedans
.Resize(1000).Name = "AH" 'en supposant qu'on a max 1000 lignes de données
i = Evaluate("max(if(len(ah)>0, row(ah),0))") - .Row + 1 'nombre de lignes à filtrer
If i <= 1 Then Exit Sub 'juste l'entête = fini
i1 = 2 'prmière ligne après l'entête
With .Resize(i) 'première colonne des données
Do While i1 <= i 'boucler jusqu'à toutes les données sont copiées
.AutoFilter 1, .Cells(i1, 1) 'autofiltre mâle
Set Ar = .Offset(1).Resize(i - 1).SpecialCells(xlVisible).Areas(1).Resize(, 3) 'plage à copier
Ar.Copy 'copier
c.PasteSpecial xlValues 'coller
ptr = ptr + 1 'compteur vertical +1
If ptr > 2 Then 'si 3eme plage
Set c = c.Offset(3 - c.Row, 4) 'recommencer 4 coloonnes vers droit, ligne 3
ptr = 0 'reset compteur
Else
Set c = c.Offset(Ar.Rows.Count + 1) 'cellule autant de cellules vers bas
End If
i1 = i1 + Ar.Rows.Count 'nouvau numéro de lgine dans la source
Loop
.AutoFilter
End With
End With
End With
MsgBox "done"
End SubBonjour Bart,
Avant, tout, je te souhaite une bonne fin d’année 2024 et le meilleur pour 2025 à toi et à toute ta famille ainsi qu’à tous les membres de ce forum,
Je suis très Content de te retrouver et comme d’habitude je suis impressionné par ton efficacité.
Le code proposé me satisfait totalement et me donne le résultat souhaité.
C’est impeccable.
Grand MERCI.
Au plaisir de te relire à l’occasion.
Salut Harzer,
Salut BsAlv,
et pour le plaisir d'en remettre une couche de boost !
Un double-clic en colonne [AH] démarre la macro.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, iTRow%, iTCol%, iIdx%, sCol$
'
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Columns("AH")) Is Nothing Then
If Range("AH3") <> "" Then
Range("AL3").Resize(UsedRange.Rows.Count, UsedRange.Columns.Count).Clear
Range("AH3:AJ" & Range("AH" & Rows.Count).End(xlUp).Row).Sort _
key1:=Range("AH3"), order1:=xlAscending, _
key2:=Range("AI3"), order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
tTab = Range("AH1:AJ" & Range("AH" & Rows.Count).End(xlUp).Row + 1).Value
For x = 4 To UBound(tTab, 1)
If tTab(x, 1) <> tTab(x - 1, 1) Then
iIdx = IIf(iIdx + 1 = 4, 1, iIdx + 1)
If iIdx = 1 Then _
iTCol = IIf(iTCol = 0, Target.Column, iTCol) + 4: _
sCol = Split(Columns(iTCol).Address(ColumnAbsolute:=False), ":")(1): _
Columns(iTCol + 2).NumberFormat = "0.00 %": _
Columns(iTCol + 3).ColumnWidth = 2
With Range(sCol & IIf(iIdx = 1, 3, Range(sCol & Rows.Count).End(xlUp).Row + 2)).Resize(x - IIf(iTRow = 0, 3, iTRow), 3)
.Value = Range("AH" & IIf(iTRow = 0, 3, iTRow)).Resize(x - IIf(iTRow = 0, 3, iTRow), 3).Value
.BorderAround LineStyle:=xlContinuous
End With
iTRow = x
End If
Next
End If
Columns.AutoFit
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End SubTrès joyeux réveillon à tous!
A+
Salut curulis57, Salut BsAlv,
Je suis très heureux de vous retrouver également curulis57, de la même manière que je l’ai dit à BsAlv.
On se retrouve comme dans le précèdent sujet à trois, de mon côté, c’est toujours avec un réel plaisir.
Cerise sur le gâteau, je me retrouve avec deux solutions aussi performantes l’une que l’autre.
Que dire de plus, si ce n’est vous renouveler à tous les deux des vives remercîments.
Très joyeux réveillon à tous les deux et cordiale poignée de mains.
Salutations Amicales.
Bonjour curulis57,
Quand j’ai reçu votre code, je l’ai testé seulement dans la feuille que j’avais créée comme fichier joint pour les tests, sauf que, lorsque j’ai pris le code pour l’implanter de mon fichier réel, je me suis rendu compte que j’avais déjà un code qui utilise le BeforeDoubleClick, Ces deux codes qui utilisent le BeforeDoubleClick pour la même feuille se perturbent entre eux.
Pouvez-vous s’il vous plait modifier le code de manière à le lier un bouton que je peux cliquer dessus pour lancer la Macro et éviter ainsi l’utilisation du BeforeDoubleClick.
D’avance merci
Bonne soirée.
Salut Harzer,
oui, bien sûr, ça peut se faire!
Mais, sache que, dans une même Sub Double-Clic(), on peut faire la distinction entre plusieurs double-clic, simplement en ciblant avec précision la cellule ou le range où le double-clic doit être détecté.
Tu peux ainsi déclencher quasi autant de macros différentes que nécessaires.
Je veux bien te mettre un bouton mais si tu m'en dis plus sur cet autre double-clic, on peut faire cohabiter les deux sans souci!
A+
C'est dans le ThisWorkBook que j'ai le code suivant :
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
If sh.Name <> Sheets("pedigree").Name Then
r = Application.match(Target.Value, Sheets("parents").Columns(1), 0)
If IsNumeric(r) Then Pedigree Target.Value, , 1
End If
End SubQuelque chose comme ça
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'
Dim tTab, iTRow%, iTCol%, iIdx%, sCol$
'
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
'
Select Case Sh.Name
Case "Nouveaux couples"
'Code...
Case "Pedigree"
'Code...
Case Else
r = Application.Match(Target.Value, Sheets("parents").Columns(1), 0)
'If IsNumeric(r) Then Pedigree Target.Value, , 1
End Select
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End SubLà, par contre, y'a à faire encore..
If IsNumeric(r) Then Pedigree Target.Value, , 1Le code complet est dans 'ThisWorkbook'.
À toi à le compléter et à le tester.
A+
Bonjour curulis57,
Je penses qu’il serait très prudent (en tout cas pour ma part) d’abandonner cette idée de vouloir faire fonctionner deux codes qui utilisent deux BeforeDoubleClick pour la même feuille.
D’autant plus, mon fichier qui fonctionnait bien, commence à avoir des lacunes : à savoir que parfois, il met beaucoup plus de temps pour fonctionner, il lui arrive même parfois de bloquer complétement et ne plus répondre.
Il doit y avoir quelques part quelque chose qui perturbe son bon fonctionnement.
En résumé, je n’arrives pas à le faire fonctionner comme il devrait l’être, donc je n’insiste plus dans cette voie.
Si tu peux répondre favorablement à ma première demande pour modifier le code de manière à le lier à bouton, je suis toujours prenant.
Bonne soirée et j’attends votre retour avec impatience.
Salutations.
Salut Harzer,
je veux bien tout ce que tu veux!
Je veux même bien jeter un oeil à ton fichier et améliorer (peut-être) ce qui cloche.
Mais, c'est toi le patron!
En attendant, là, dodo!
A+
Bonjour curulis57,
je veux bien tout ce que tu veux!
Je veux même bien jeter un œil à ton fichier et améliorer (peut-être) ce qui cloche.
Merci pour ta proposition et disponibilité, j’en prends note, au cas où la situation se présente.
Toutefois, j’ai enfin trouvé ce qui posait problème et c’est de ma faute, enfin.... c’est un oublie!
J’ai modifié le code comme tu me suggéré le lundi 30/12/2024 à 22h17 au niveau de :
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)Seulement, j’ai complétement oublié de supprimer le code que j’avais déjà mis avant au niveau de :
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Si je comprends bien, j'activais deux Macros identiques au même temps. et c'est là ou les problèmes ont commencés.
Je suis content de retouver mon fichier à sa situation initiale.
Bonne fêtes de fin d'année.
Bien vu! Rien de bien compliqué dans VBA sinon de la belle logique : tu seras bientôt un vrai crack!
Joyeux réveillon!
A+
Si je comprends bien, j'activais deux Macros identiques au même temps. et
pas vrai, je crois, l'un sera (tout petit) plus tôt que l'autre (si vous ajoutez un msgbox dans les 2 avec msgbox "thisworkbook" et msgbox "sheet"), vous verrez, un pari, je pense que "thisworkbook" gagne !!!
Bonjour curulis57 & BsAlv,
je réponds à BsAlv pour lui donner les résultats de mon compte rendu après les essais :
J’ai essayé de comprendre un peu le fonctionnement lorsque les deux codes sont existants, j’ai suivi les recommandations de BsAlv en mettant deux MsgBox dans les deux codes pour savoir comment cela va se dérouler.
J’ai lancé la Macro en faisant un double-click sur une des cellules de la colonne "AH" de la feuille "Nouveaux couples", voici donc comment les choses se sont déroulées :
Et bien les deux codes se lancent l’un après l’autre, la première macro qui s’est lancée, c’est celle qui se trouve dans la feuille "Nouveaux couples", donc celle qui se trouve dans :
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)Ensuite , la deuxième Marco qui s’est lancée en 2e lieu, c’est celle qui se trouve dans Workbook :
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)J'ai fais une capture d'écran (en vidéo) qui afiche les déroulments des choses mais je n'arrives pas à le joindre en pièce jointe
Reste à savoir laquelle des deux Macro copie le résultat dans les autres colonnes, je vous avoues que je ne le sais pas!!!!