Discussion :

[amayasanfield]

Bonjour à tous,

Je reviens vers vous afin de solliciter votre aide au sujet d’un problème auquel je ne trouve pas de solutions depuis un certain temps.

J’ai un code développé par un membre du forum qui fonctionne partiellement, il me permet de fusionner selon le critère à la colonne A et d’additionner les sommes à la colonne L sauf que j’aimerais rajouter une condition afin de ne fusionner les lignes uniquement si les critères à la colonne A et I sont identiques et qui reprend les données aux autres colonnes de la dernière ligne.

Vous trouverez ci-joint un fichier excel qui explique le mécanisme.

Le code que je détiens est le suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Dim tTab, lgPos As Variant, lgPos1 As Variant, dbTot As Variant, sItem As Variant
 
Application.ScreenUpdating = False
iRow = Range("A" & Rows.Count).End(xlUp).Row
iCol = Cells(1, Columns.Count).End(xlToLeft).Column
Range("A1").Resize(iRow, iCol).Sort key1:=Range("A2"), order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlYes
tTab = Range("A1").Resize(iRow + 1, iCol).Value
lgPos = 3
lgPos1 = 2
sItem = tTab(2, 1)
Do
   If tTab(lgPos, 1) = sItem Then tTab(lgPos - 1, 1) = ""
    If tTab(lgPos, 1) <> sItem Then
        dbTot = 0
        For y = lgPos1 To lgPos - 1
 
        dbTot = dbTot + CDbl(tTab(y, UBound(tTab, 2)))
 
        Next
        tTab(lgPos - 1, UBound(tTab, 2)) = dbTot
        lgPos1 = lgPos
        sItem = tTab(lgPos, 1)
    End If
    lgPos = lgPos + 1
Loop Until lgPos > UBound(tTab, 1)
With Worksheets("Fusion de lignesl")
    .Range("A1").Resize(iRow, iCol).Value = tTab
 
    .Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
 
    .Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
    .Range("A1").Resize(1, iCol).Interior.ColorIndex = 15
    .Columns.AutoFit
    .Activate
End With

En vous remerciant par avance.

AMAYAS

[ARTURO83]

Bonjour,

Voici, après avoir lancé la macro, les lignes inutiles ne sont pas supprimées, mais simplement masquées de même que les colonnes L et M, ce qui vous permet en les démasquant, de rejouer le scénario.
Pièce jointe 579875
.
Le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub Fusion()
    Dim DerLig As Long, i As Long, j As Long, LigRef As Long
    Dim Ref As String
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    Range("M2:M" & DerLig).FormulaR1C1 = "=RC[-12]&"" ""&RC[-4]" 'on associe par formule la référence et la périodicité
    Range("M2:M" & DerLig).Value = Range("M2:M" & DerLig).Value 'que l'on place en colonne M
    Range("M1").Select
    For i = DerLig To 2 Step -1 'on part de la dernière position en remontant
        If Cells(i, "M") <> "" Then 'Si la cellule M n'est pas vide
            Ref = Cells(i, "M") 'on relève la référence en colonne A
            LigRef = i 'on relève le N° de ligne de la référence traitée
            'on recherche la première position correspondant à référence et la périodicité en colonne M
            Set d = Range("M1:M" & DerLig).Find(What:=Ref, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            Cells(i, "N") = Application.WorksheetFunction.Sum(Range(Cells(d.Row, "L"), Cells(i, "L")))
            For j = i - 1 To d.Row Step -1 'on fait la somme des valeurs de la colonne L de la première position à la dernière position
                If Cells(j, "M") = Ref Then Cells(j, "M") = "" 'on efface toutes les références identiques trouvées au-dessus de celle qui est traitée
            Next j
        End If
    Next 'on traite la référence suivante
 
    'masquage des lignes devenues inutiles
    For i = DerLig To 2 Step -1 'on part de la dernière position en remontant
        If Cells(i, "M") = "" Then Rows(i).Hidden = True
    Next
 
    'masquage des colonne L et M
    Columns("L:M").Hidden = True
End Sub

Cdlt

[amayasanfield]

Bonjour Arturo,

Je te remercie pour ta réponse pertinente.
Le principe de la démarche est de réduire la taille des fichiers afin qu'ils soient exploitables vu qu'initialement ils font des centaines de millers de lignes.
Ton idée d'associer par formule la référence et la périodicité est une excellente idée, je me demande comment j'ai fait pour ne pas y penser. je vais te prendre cela en te remerciant pour ton aide

Bonne journée à toi.

Amayas