Fusion d'onglets d'après la valeur d'une cellule Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Répondre
e
edlede
Membre dévoué
Membre dévoué
Messages : 745
Appréciations reçues : 6
Inscrit le : 4 novembre 2015
Version d'Excel : 2013

Message par edlede » 2 mars 2017, 17:32

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
test extraction.xlsm
(92.42 Kio) Téléchargé 7 fois
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 9'461
Appréciations reçues : 428
Inscrit le : 16 juin 2013
Version d'Excel : 365 UK Windows 10

Message par h2so4 » 2 mars 2017, 19:08

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
e
edlede
Membre dévoué
Membre dévoué
Messages : 745
Appréciations reçues : 6
Inscrit le : 4 novembre 2015
Version d'Excel : 2013

Message par edlede » 2 mars 2017, 19:18

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 ?
e
edlede
Membre dévoué
Membre dévoué
Messages : 745
Appréciations reçues : 6
Inscrit le : 4 novembre 2015
Version d'Excel : 2013

Message par edlede » 2 mars 2017, 22:41

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?
h
h2so4
Passionné d'Excel
Passionné d'Excel
Messages : 9'461
Appréciations reçues : 428
Inscrit le : 16 juin 2013
Version d'Excel : 365 UK Windows 10

Message par h2so4 » 2 mars 2017, 23:02

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
 
e
edlede
Membre dévoué
Membre dévoué
Messages : 745
Appréciations reçues : 6
Inscrit le : 4 novembre 2015
Version d'Excel : 2013

Message par edlede » 2 mars 2017, 23:46

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 :lol:
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 °oO ) 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
e
edlede
Membre dévoué
Membre dévoué
Messages : 745
Appréciations reçues : 6
Inscrit le : 4 novembre 2015
Version d'Excel : 2013

Message par edlede » 8 mars 2017, 14:05

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
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message