regroupement de lignes Excel

Question

Bonjour J'ai ce code qui regoupe plusieurs colonnes dans un même fichier selon des périodes d'activités. J'aimerais regrouper toutes les lignes ayant le même matricule sur une seule ligne Je cherche depuis un certain temps et je sèche Quelqu'un a t il une idée Voici le code en question Option Explicit Public Flag As Boolean, Drapeau As Boolean Sub bb() Dim Tableau_A() Dim Fichier_traité As String, i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, n As Integer, o As Integer Dim Chemin As String, Nombre_colonnes As Integer, Prochaine_ligne As Integer, DerLig_Feuille_traitée As Integer Dim Ligne_Début As Integer, Ligne_Fin As Integer, Nom_ficher_base As String Dim Genre_de_Fichiers As String, Nom_Nouveau_Fichier As String Dim DerLig As Integer Application.ScreenUpdating = False ThisWorkbook.Save ' Par sécurité, si une modification de dernière minute a été apportée au fichier de base Application.DisplayAlerts = False If Range("C13") = 1 Then Genre_de_Fichiers = "LIASSE" Sheets("sql LIASSE").Visible = True Sheets("sql LIASSE").Activate End If Sheets("Base").Delete Application.DisplayAlerts = True Rows("2:65536").Delete Nombre_colonnes = Range("IV1").End(xlToLeft).Column ReDim Tableau_A(Nombre_colonnes) For i = 1 To Nombre_colonnes Tableau_A(i) = Cells(1, i) Next i Chemin = ThisWorkbook.Path & "" Nom_ficher_base = ThisWorkbook.Name Fichier_traité = Dir(Chemin & "*.*") 'Variante pour boucler sur tous les types de fichiers Do While Fichier_traité <> "" If Left(Fichier_traité, 6) <> Genre_de_Fichiers Then GoTo Etiquette Workbooks.Open Chemin & Fichier_traité For j = 1 To ActiveWorkbook.Sheets.Count Sheets(j).Activate If ActiveWorkbook.Sheets(j).Cells(2, 1) = "" Then GoTo Etiquette_Bis If Genre_de_Fichiers = "LIASSE" Then Prochaine_ligne = ThisWorkbook.Sheets("sql LIASSE").UsedRange.Rows.Count + 1 End If For k = 1 To ActiveWorkbook.Sheets(j).Range("IV1").End(xlToLeft).Column For l = 1 To Nombre_colonnes If ActiveWorkbook.Sheets(j).Cells(1, k) = Tableau_A(l) Then DerLig_Feuille_traitée = ActiveWorkbook.Sheets(j).Range("A65536").End(xlUp).Row If Genre_de_Fichiers = "LIASSE" Then ActiveWorkbook.Sheets(j).Range(Cells(2, k), Cells(DerLig_Feuille_traitée, k)).Copy Destination:=ThisWorkbook.Sheets("sql LIASSE").Cells(Prochaine_ligne, l) End If End If Next l Next k Etiquette_Bis: Next j Workbooks(Fichier_traité).Close False Etiquette: Fichier_traité = Dir Loop ' Tri des données exportées Cells.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("D1"), Order1:=xlAscending, Header:=xlYes If Genre_de_Fichiers = "LIASSE" Then ActiveWorkbook.SaveAs Filename:=Chemin & "Contrôle LIASSE FISCALE" End If Nom_Nouveau_Fichier = ActiveWorkbook.Name ' Regroupement des lignes Range("A2").Activate Retour: If ActiveCell = "" Then GoTo Fin_Regroupement Ligne_Début = ActiveCell.Row ' Un même "Matricule" peut avoir plusieurs "DebutPeriodeActivite" Do Until ActiveCell <> ActiveCell.Offset(1, 0) Or ActiveCell.Offset(0, 3) <> ActiveCell.Offset(1, 3) ActiveCell.Offset(1, 0).Activate Loop Ligne_Fin = ActiveCell.Row For m = Ligne_Début + 1 To Ligne_Fin ' On ne touche pas la première ligne du bloc For n = 8 To Range("IV1").End(xlToLeft).Column 'De la colonne H à la colonne ???? Ca peut évoluer If Cells(1, n) "Montant des frais professionnels" Or Cells(1, n) "Code type de frais professionnels" Or Cells(1, n) = "Base brute Sécurité Sociale pour la période" Then Cells(Ligne_Début, n) = Cells(Ligne_Début, n) + Cells(m, n) If Cells(Ligne_Début, n) 0 Then Cells(Ligne_Début, n) "" Else If Cells(m, n) <> "" And Cells(m, n) = Cells(Ligne_Début, n) Then GoTo Uniquement_Inscrire_X Else If Cells(m, n) <> "" And Cells(Ligne_Début, n) <> "" Then MsgBox ("Pour le ''Matricule - " & Cells(Ligne_Début, 1) & "'' à la date ''DebutPeriodeActivite - " & Cells(Ligne_Début, 4) & "'', le regroupement n'a pas pu être effectué") GoTo Si_problème Else If Cells(m, n) <> "" Then Cells(Ligne_Début, n) = Cells(m, n) End If End If End If End If Next n Uniquement_Inscrire_X: Cells(m, 26) = "X" 'permettra d'effacer cette ligne par la suite Next m Si_problème: ActiveCell.Offset(1, 0).Activate GoTo Retour Fin_Regroupement: ' Effacement des lignes avec des "X" DerLig = Range("A" & Rows.Count).End(xlUp).Row Columns("Z:Z").AutoFilter Range("$Z$1:$Z$" & DerLig).AutoFilter Field:=1, Criteria1:="X", Operator:=xlAnd Rows("2:" & DerLig).SpecialCells(xlCellTypeVisible).Delete Columns("Z:Z").AutoFilter If Genre_de_Fichiers = "LIASSE" Then Sheets("sql LIASSE").Copy Before:=Sheets(1) Sheets("sql LIASSE (2)").Name = "Copie de travail LIASSE" Sheets("sql LIASSE").Visible = False End If Application.ScreenUpdating = True MsgBox "Un nouveau fichier ''" & Nom_Nouveau_Fichier & "'' a été créé et est actuellement ouvert à l'écran." & Chr(13) & Chr(13) & "Le fichier de base ''" & Nom_ficher_base & "'' a été refermé sans modification." ActiveWorkbook.Save End Sub Merci beaucoup Cdt

jordane45 · Answer

Bonjour,

je n'ai pas totalement essayé de comprendre ce code.. un peu trop long à lire de si bon matin 

Si j'ai bien compris, tu cherches à "synthétiser" toutes les lignes ayant le même matricule ?
Je pense qu'en utilisant une boucle et du "findAll" tu pourrais t'en sortir.

Pour le findAll je t'invite à regarder cette page :
FinALL Exemple
-> c'est un code que j'ai récupéré à l'époque et qui fonctionne plutot bien

SInon, en utilisant, comme dans ton code ci-dessus, une boucle + des filtres tu peux également t'en sortir.
Par contre, plutot que de copier intégralement du code.... il serait bien de nous indiquer où tu bloques.

Je pense que peu de personnes prendront le temps d'analyser le code copié tel quel sans aucune autre indication de ce qu'il fait, comment il le fait et où ça bloque.

Bonne continuation.
Cordialement,
Jordane



Cordialement,
Jordane,
______________________________________________________
Règles du forum à lire avant de poster une question : ICI

Regroupement de lignes Excel

1 réponse

Votre réponse

Discussions similaires