Ecriture d'une macro

[TWINS]

Bonjour à tous

J'aimerais savoir si qq peut me faire une macro sur le fichier joint qui concerne une application d'inventaire
Voici le problème :

Chaque fois qu'il y a un " * " dans la colonne A, les cellules des colonnes B, C et D sont fusionnées (de 2 à 15 lignes)
En colonne X j'ai 1 chiffre par ligne potentiellement (il s'agit de qtés comptées à différents endroits pour le même produit de la colonne D

Le but de la macro est de fractionner les cellules fusionnées et de faire la somme des lignes de la colonne X qui concerne ce produit

Pour que ce soit plus clair , le tableau vous donne un exemple "Avant / Après"

D'avance merci à celui qui pourra m'aider
Cordialement

Franck

 

[GI_GI]

Re : Ecriture d'une macro

Bonjour a tous
Un essai en PJ

 

[klin89]

Re : Ecriture d'une macro

Bonsoir GI_GI, TWINS, le forum

Une autre façon de procéder :
A tester.

Option Explicit

Sub test()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Copie").Delete
    Application.DisplayAlerts = True
    Sheets("Exemple maco somme lots").Copy after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "Copie"
    With Sheets("copie")
        .Move before:=Sheets("Exemple maco somme lots")
        With .Columns("a:d")
            .MergeCells = False
        End With
        With .Range("a8", .Range("x" & Rows.Count).End(xlUp))
            With .Offset(, 1).Resize(, 3)
                .SpecialCells(4).Formula = "=r[-1]c"
                .Value = .Value
            End With
        End With
        On Error GoTo 0
        With .Range("a6", .Range("x" & Rows.Count).End(xlUp))
            a = .Value: n = 2
            With CreateObject("Scripting.Dictionary")
                .CompareMode = 1
                For i = 3 To UBound(a, 1)
                    txt = Join(Array(a(i, 2), a(i, 3), a(i, 4)), Chr(2))
                    If Not .exists(txt) Then
                        n = n + 1: .Item(txt) = n
                        For j = 1 To UBound(a, 2)
                            a(n, j) = a(i, j)
                        Next
                    Else
                        a(.Item(txt), 24) = a(.Item(txt), 24) + a(i, 24)
                    End If
                Next
            End With
        End With
    End With
    'Restitution en Feuil1
    With Sheets("Feuil1")
        .Cells.Clear
        With .Range("A1").Resize(n, UBound(a, 2))
            .Value = a
            .Columns.ColumnWidth = 1
            .Columns.AutoFit
            .Parent.Activate
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[klin89]

Re : Ecriture d'une macro

Bonsoir le forum,

Finalement, je préfère employer la propriété MergeArea.
Pas tellement l'habitude de jouer avec les cellules fusionnées

Option Explicit

Sub test()
Dim r As Range, i As Byte, n As Long, maxrow As Long, b()
    Application.ScreenUpdating = False
    ReDim b(1 To 1000, 1 To 24)
    With Sheets("Exemple maco somme lots")
        With .Range("a8", .Range("x" & Rows.Count).End(xlUp))
            For Each r In .Columns(2).SpecialCells(2)
                n = n + 1
                If r.MergeCells Then
                    If r.Address = r.MergeArea.Cells(1).Address Then
                        With r.MergeArea.Offset(, -1).Resize(, 24)
                            For i = 1 To .Columns.Count - 1
                                b(n, i) = .Cells(i).Value
                            Next
                            b(n, .Columns.Count) = Application.Sum(.Cells(.Columns.Count).Resize(r.MergeArea.Rows.Count))
                        End With
                    Else
                        n = n - 1
                    End If
                Else
                    With r.Offset(, -1).Resize(, 24)
                        For i = 1 To .Columns.Count
                            b(n, i) = .Cells(i).Value
                        Next
                    End With
                End If
            Next
        End With
    End With
    'Restitution en Feuil1
    With Sheets("Feuil1")
        .Cells.Clear
        Sheets("Exemple maco somme lots").Range("a6:x7").Copy
        .Range("a1").PasteSpecial xlValues
        With .Range("A1")
            With .Offset(2).Resize(n, UBound(b, 2))
                .Value = b
            End With
            maxrow = .Range("B" & Rows.Count).End(xlUp).Row
            With .CurrentRegion.Resize(maxrow, 24)
                .Font.Name = "calibri"
                .Font.Size = 10
                .VerticalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                With .Rows(1).Resize(2)
                    With .Resize(, 4)
                        .Interior.ColorIndex = 15
                    End With
                    .BorderAround Weight:=xlThin
                End With
                .Columns.ColumnWidth = 1
                .Columns.AutoFit
            End With
            .Parent.Activate
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[TWINS]

Re : Ecriture d'une macro

Bonjour
Un grand merci à Klin 89
La première version du code a fonctionné parfaitement et m'a fait gagné un paquet de temps dans mon inventaire

Merci encore
A bientôt
twins

 

[CBernardT]

Re : Ecriture d'une macro

Bonjour TWINS, GI_GI, klin89 et le Forum,

Les solutions déjà données donnant satisfaction, j'ajoute une solution sans autre prétention que d'utiliser un code simple.