Fusion d'onglets d'après la valeur d'une cellule

Bonjour à tous,

Je suis devant un problème mais je ne vois pas comment le résoudre.

Voilà j'ai des onglets avec des noms différents mais certain d'entre eux ont en C13 la même valeur.

Je voudrais fusionner ces onglets et les renommer avec la valeur en C13 et supprimer les anciens onglets "parents"

Mais je manque cruellement d'idées,

je vous fournis un petit exemple, ici les deux derniers onglets ont la même valeur en C13

Et je reste à votre disposition pour toutes questions complémentaires

Merci d'avance pour vos solutions

bonsoir,

tout d'abord une proposition de correction

Suite à l'envoi d'examens sous-traités au sein de votre laboratoire, nous somme toujours en attente du retour de résultats ou d'une attestation d'envoi dans le cas de recherche génétique pour les patients suivants :

ensuite un proposition de macro, (à tester sur une copie de ton classeur original)

Sub fusion()
    For Each ws In Worksheets
        found = False
        For Each wsc In Worksheets
            If ws.Name <> wsc.Name Then
                If ws.Range("C13") = wsc.Name Then
                    ws.Rows(23).Copy
                    wsc.Rows(23).Insert shift:=xlDown
                    dl = wsc.Cells(Rows.Count, "B").End(xlUp).Row
                    Cells(dl, "F").Formula = "=sum(f23:f" & dl - 1 & ")"
                    Application.DisplayAlerts = False
                    ws.Delete
                    Application.DisplayAlerts = True
                    found = True
                    Exit For
                End If
            Else
                found = True
            End If
        Next wsc
        If Not found Then
            ws.Name = Left(ws.Range("C13"), 31)
        End If
    Next ws
End Sub

Merci je test ça dès que les enfants dorment par contre je ai pas bien compris la correction tu as juste recouper sur 3 lignes ?

Bon je dois m y prendre mal mais j'arrive pas à grand chose j'ai rajouté au début un

Sub fusion()

i = Worksheets.Count

For j = 2 To i

For Each ws In Worksheets

found = False

For Each wsc In Worksheets

If ws.Name <> wsc.Name Then

If ws.Range("C13") = wsc.Name Then

ws.Rows(23).Copy

wsc.Rows(23).Insert shift:=xlDown

dl = wsc.Cells(Rows.Count, "B").End(xlUp).Row

Cells(dl, "F").Formula = "=sum(f23:f" & dl - 1 & ")"

Application.DisplayAlerts = False

ws.Delete

Application.DisplayAlerts = True

found = True

Exit For

End If

Else

found = True

End If

Next wsc

If Not found Then

ws.Name = Left(ws.Range("C13"), 31)

End If

Next ws

Next j

End Sub

pour que cela mouline 20 secondes mais je ne vois aucune fusion n y la suppression d'onglet.( mon i est toujours = à 162)

Et je comprend pas le "wsc" dans ton code

merci pour tes éclairages, et veux tu un fichier plus complets?

Bonsoir,

sorry, j'ai posté une mauvaise version, pour ce qui concerne la correction des lignes , j'ai juste corrigé les fautes d'orthographe.

ce code-ci fonctionne sur le fichier que tu as mis en exemple.

Sub fusion()
    For Each ws In Worksheets
        found = False
        For Each wsc In Worksheets
            If ws.Name <> wsc.Name Then
                If Left(ws.Range("C13"), 31) = wsc.Name Then
                    ws.Rows(23).Copy
                    wsc.Rows(23).Insert shift:=xlDown
                    dl = wsc.Cells(Rows.Count, "B").End(xlUp).Row
                    Cells(dl, "F").Formula = "=sum(f23:f" & dl - 1 & ")"
                    Application.DisplayAlerts = False
                    ws.Delete
                    Application.DisplayAlerts = True
                    found = True
                    Exit For
                End If
            End If
        Next wsc
        If Not found Then
            ws.Name = Left(ws.Range("C13"), 31)
        End If
    Next ws
End Sub

Bon, je crois que la fatigue l'emporte sur la macro lol effectivement ca marche nickel sur mon fichier exemple mais pas sur mon principal

je le test depuis une demi heure et je comprend pas pourquoi ca tourne pas rond je vais prendre un peu de repos ( le réveil sonne dans 4 heures ) et je reviens vers vous si besoin je dois faire un fausse manip vue que mon exemple est juste une copie des 3 derniers onglets de mon fichier initiale....

Et encore un super Merci pour le code

Bonjour à tous,

Voici la solution finale vu avec H2SO4 en mp

Sub fusion()
    For Each ws In Worksheets 'on prend chaque feuille 1 à 1
        found = False ' par défaut, on n'a pas trouvé de feuille portant le nom trouvé en C13
        If ws.Name <> "Masque" Then 'si masque on passe à la feuille suivante
        If ws.Range("C13") = "" Then ws.Range("C13") = "Aucun" 'si pas de nom en C13, nom=aucun
        For Each wsc In Worksheets 'on cherche une feuille portant le nom trouvé en C13
            If ws.Name <> wsc.Name Then '
                If UCase(Left(ws.Range("C13"), 31)) = UCase(wsc.Name) Then 'on a trouvé
                    ws.Rows(21).Copy 'on copie la ligne 21 de la feuille ws
                    wsc.Rows(21).Insert shift:=xlDown 'on l'insère sur la feuille wsc
                    dl = wsc.Cells(Rows.Count, "B").End(xlUp).Row
                    wsc.Cells(dl, "F").Formula = "=sum(f21:f" & dl - 1 & ")" 'on adapte la formule du total
                    Application.DisplayAlerts = False
                    ws.Delete 'on supprime la feuille ws
                    Application.DisplayAlerts = True
                    found = True 'on indique qu'on a trouvé une feuille portant le nom trouvé en C13
                    Exit For 'on sort de la boucle
                End If
            End If
        Next wsc
        If Not found Then 'si on a pas trouvé de feuille portant le nom trouvé en C13
            ws.Name = Left(ws.Range("C13"), 31) 'on nomme la feuille ws du nom trouvé en C13
        End If
        End If
    Next ws
End Sub
 

Un grand merci à H2SO4 car sans lui je serai encore bloqué!

A bientôt