Renomer Cellule suivant contenue de la cellule + fusion

Le 14/04/2023 à 09:22

Bonjour ,

Je souhaiterais une macro qui me permettrait de modifier le nom d'une cellule suivant une partie de son contenue.

Pour être plus clair dans une cellule de la colonne C on trouve "2427ST002_Pot-Ressort-standard-Ø32-GRP1 2480753F-1" je voudrais pouvoir détecter le mot "2480753F" est renommer la cellule en "2427ST002 - 2480753F" .

Idem pour le mot "153658k"

Car on retrouve plusieurs ligne avec juste en fin "-1", "-2" ....

Donc pour finir si on arrive a renommer ces cellules j'aurais 3 fois "2427ST002 - 2480753F" et 3 fois "2427ST002 - 153658k" donc je souhaiterais savoir si on peut faire en sorte qu'il reste qu'une seule ligne "2427ST002 - 2480753F" et "2427ST002 - 153658k" avec les quantité qui se sont additioner.

je ne sais pas si je suis assez claire ;)

Merci de votre aide

5test.xlsx (8.97 Ko)
Le 14/04/2023 à 10:00

Bonjour Val_LG

On peut utiliser une formule, certes un peu alambiquée

7val-lg-test.xlsx (15.50 Ko)

A+

Le 14/04/2023 à 10:13

Bonjour,

Sinon en VBA:

dans la macro suivante, on supprime les lignes communes.

Sub Calcul()
    Dim i As Long, DerLig As Long, Dern_Tiret As Long, Dern_Espace As Long
    Application.ScreenUpdating = False
    DerLig = Range("C" & Rows.Count).End(xlUp).Row
    For i = DerLig To 8 Step -1
        Dern_Tiret = InStrRev(Cells(i, "C"), "-", -1)
        Dern_Espace = InStrRev(Cells(i, "C"), " ", -1)
        Cells(i, "C") = Mid(Cells(i, "C"), Dern_Espace + 1, Dern_Tiret - Dern_Espace - 1)
    Next i

    For i = DerLig - 1 To 8 Step -1
        If Cells(i, "C") = Cells(i + 1, "C") Then
            Cells(i, "D") = Cells(i, "D") + Cells(i + 1, "D")
            Range(Cells(i + 1, "C"), Cells(i + 1, "G")).Delete
        End If
    Next i
End Sub

Dans celle-ci, on fusionne les cellules communes de la colonne C

Sub Calcul_2()
    Dim i As Long, DerLig As Long, Dern_Tiret As Long, Dern_Espace As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    DerLig = Range("C" & Rows.Count).End(xlUp).Row
    For i = DerLig To 8 Step -1
        Dern_Tiret = InStrRev(Cells(i, "C"), "-", -1)
        Dern_Espace = InStrRev(Cells(i, "C"), " ", -1)
        Cells(i, "C") = Mid(Cells(i, "C"), Dern_Espace + 1, Dern_Tiret - Dern_Espace - 1)
    Next i

    For i = DerLig - 1 To 8 Step -1
        If Cells(i, "C") = Cells(i + 1, "C") Then
            Range(Cells(i, "C"), Cells(i + 1, "C")).MergeCells = True
        End If
    Next i
End Sub

Cdlt

Le 14/04/2023 à 10:27

Bonjour merci pour vos réponses .

Ce n'est pas exactement mon besoin .

J'ai vraiment besoin que dans un premiers temps les cellules soit renommé et après fusionné les lignes pour avoir une seule ligne avec les quantités additionner

Le 14/04/2023 à 10:52

Parmi mes 2 propositions , aucune ne correspond à vos attentes?

Ou bien, celle-ci:

Sub Calcul_3()
    Dim i As Long, DerLig As Long, Dern_Tiret As Long, Dern_Espace As Long
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    DerLig = Range("C" & Rows.Count).End(xlUp).Row
    For i = DerLig - 1 To 8 Step -1
        Dern_Tiret = InStrRev(Cells(i, "C"), "-", -1)
        Dern_Espace = InStrRev(Cells(i, "C"), " ", -1)
        Cells(i, "C") = Mid(Cells(i, "C"), Dern_Espace + 1, Dern_Tiret - Dern_Espace - 1)
        On Error Resume Next
        Dern_Tiret_1 = InStrRev(Cells(i + 1, "C"), "-", -1)
        Dern_Espace_1 = InStrRev(Cells(i + 1, "C"), " ", -1)
        If Err.Number = 0 Then
            Cells(i + 1, "C") = Mid(Cells(i + 1, "C"), Dern_Espace_1 + 1, Dern_Tiret_1 - Dern_Espace_1 - 1)
            If Cells(i, "C") = Cells(i + 1, "C") Then
                Cells(i, "D") = Cells(i, "D") + Cells(i + 1, "D")
                Range(Cells(i, "C"), Cells(i + 1, "C")).MergeCells = True
                Range(Cells(i, "D"), Cells(i + 1, "D")).MergeCells = True
                Range(Cells(i, "E"), Cells(i + 1, "E")).MergeCells = True
                Range(Cells(i, "F"), Cells(i + 1, "F")).MergeCells = True
                Range(Cells(i, "G"), Cells(i + 1, "G")).MergeCells = True
                Range(Cells(i, "H"), Cells(i + 1, "H")).MergeCells = True
            End If
            On Error GoTo 0
        End If
    Next i
End Sub
Le 14/04/2023 à 11:24

Bonjour je peux vous proposer ceci :

Sub Macro1()

Static ref
Dim n
If IsNull(ref) Then Set ref = CreateObject("Scripting.Dictionary")
n = 0
For i = 2 To Range(Range("C2"), Range("C2").End(xlDown)).Rows.Count() + 1
    Dim val, t, nval
    val = Range("C" & i - n).Value
    t = Split(val, "_")
    If UBound(t) < 1 Then GoTo nc
    nval = t(0)

    t = Split(t(1), " ")
    nval = nval & " - " & Split(t(1), "-")(0)

    If ref.exists(nval) Then
        Range(ref.Item(nval)).Value = Range(ref(nval)).Value + Range("D" & i - n).Value
        Rows(str(i - n) & ":" & i - n).Delete Shift:=xlUp
        n = n + 1
    Else
        ref.Add nval, "D" & i - n
        Range("C" & i - n).Value = nval
    End If
nc:
    Next i
End Sub

Si cela ne correspond pas à votre besoin merci de le préciser avec un exemple concret.

Cordialement,

Le 14/04/2023 à 11:49

Alor si je vasi essayer d'écrire ce que j'imagine :

si il trouve dans une cellules de la colonne C, "2480753F" alors remplacer le texte de la cellule par "2427ST002-2480753F"

Pareil pour "153658k"

et si cela se déroule bien je me retrouver avec 3 lignes 2427ST002-2480753F avec une quantité de 3 / 8 / 1

donc supprimer les lignes 9 et 10, et ajouter ces quantité dans la quatité de la ligne 8 .

Soit dans la ligne 8 une quantité de 12

Idem pour 153658k

A noter qu'il s'agit d'un extrait d'un tableur de plusieurs Milliers de lignes . je souhaite donc avoir un programme qui me permettrait de faire ceci que j'adapterais sur le vrai fichier

Merci de toutes vos réponses

Le 14/04/2023 à 12:00

Donc cela rejoint ma première proposition, sauf que j'avais oublié la première partie du code à conservé:

Sub Calcul()
    Dim i As Long, DerLig As Long, Dern_Tiret As Long, Dern_Espace As Long, Prem_Tiret As Long
    Application.ScreenUpdating = False
    DerLig = Range("C" & Rows.Count).End(xlUp).Row
    For i = DerLig To 8 Step -1
        Prem_Tiret = InStr(1, Cells(i, "C"), "_", 1)
        Dern_Tiret = InStrRev(Cells(i, "C"), "-", -1)
        Dern_Espace = InStrRev(Cells(i, "C"), " ", -1)
        Cells(i, "C") = Left(Cells(i, "C"), Prem_Tiret) & Mid(Cells(i, "C"), Dern_Espace + 1, Dern_Tiret - Dern_Espace - 1)
    Next i

    For i = DerLig - 1 To 8 Step -1
        If Cells(i, "C") = Cells(i + 1, "C") Then
            Cells(i, "D") = Cells(i, "D") + Cells(i + 1, "D")
            Range(Cells(i + 1, "C"), Cells(i + 1, "G")).Delete
        End If
    Next i
End Sub
Le 14/04/2023 à 13:26

Le code que j'ai envoyer transforme (à condition de bien adapter la 1ere ligne étudié, 2 dans le code envoyé contre 8 dans le fichier exemple) ça :

image

en ça :

image

et puis si on rajoute des lignes comme ça :

image

et qu'on relance la macro ça donne ça :

image

c'est pas ce que tu cherches ?
par exemple concret je pensais à une démonstration du résultat attendu fait à la main

Le 14/04/2023 à 13:58

Bonjour le fil,

En reprenant l'idée de Chbouli04 que je salue et en l'exprimant plus simplement à mes yeux,
voici un code qui comme le sien donne ce que vous avez demandé 

Sub CompilationRef()
  Dim dLig As Long, Lig As Long
  Dim Ind As Long, TabRef(), MaRef As String
  Dim sG As String, sD As String, sTmp As String
  Dim TotQt As Single
  Dim Un As Collection
  ' Définir une nouvelle collection (sans doublon)
  Set Un = New Collection
  ' Avec la feuille
  With Sheets("Feuil1")
    ' Dernière ligne remplie de la colonne
    dLig = .Range("C" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne
    For Lig = 8 To dLig
      ' Mémoriser la valeur de la cellule
      sTmp = .Range("C" & Lig).Value
      ' PArtie gauche de la ref
      sG = Left(sTmp, InStr(1, sTmp, "_") - 1)
      sD = Mid(sTmp, InStr(1, sTmp, " ") + 1)
      ' On supprimer le tiret et chiffre
      sD = Left(sD, Len(sD) - 2)
      MaRef = sG & "-" & sD
      ' Pour éviter les erreurs
      On Error Resume Next
      ' On ajoute la REF à la collection
      Un.Add MaRef, CStr(MaRef)
      ' Si aucune erreur = n'est pas un doublon
      If Err = 0 Then
        ' Inscrire le total de la ligne précédente
        TabRef(1, Ind) = TotQt: TotQt = 0
        ' Passer à la ligne suivante
        Ind = UBound(TabRef, 2) + 1
        ReDim Preserve TabRef(5, Ind)
      End If
      ' Si la ref actuelle n'est pas enregistrée dans le tableau
      If TabRef(0, Ind) <> MaRef Then
        TabRef(0, Ind) = MaRef
        TabRef(2, Ind) = .Range("E" & Lig).Value
        TabRef(3, Ind) = .Range("F" & Lig).Value
        TabRef(4, Ind) = .Range("G" & Lig).Value
      End If
      ' Faire le total de la même REF
      TotQt = TotQt + .Range("D" & Lig).Value
    Next Lig
    ' Inscrire le dernier total dans le tableau
    TabRef(1, Ind) = TotQt: TotQt = 0
    ' Restituer le résultat
    .Range("I8").Resize(UBound(TabRef, 2) + 1, 6).Value = Application.Transpose(TabRef)
  End With
End Sub

Nota : j'ai mis le résultat à partir de I8 pour que vous puissiez le voir concrètement

A+

Rechercher des sujets similaires à "renomer suivant contenue fusion"