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 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