Fusionner/défusionner automatiquement des cellules identiques

Bonjour,

Je suis totalement novice en VBA et j'essaie de bricoler un planning de réservation automatique de véhicules pour mon travail.

J'ai crée deux macros: une pour réserver un véhicule, une pour supprimer la réservation.

Pour réserver, ce que j'aimerais, c'est que, lorsque deux cellules d'une colonne (le planning court des colonnes C à V) contiennent la même chose (en l'occurrence un nom), elles soient fusionnées et centrées.

Pour supprimer, une fois la cellule à supprimer identifiée par la macro (ça, c'est ok, j'ai réussi), j'ai besoin qu'elle supprime le contenu et défusionne les cellules.

Pour réserver, j'ai trouvé du code qui fonctionne mais uniquement sur une colonne (ici, la I) et je ne sais pas comment lui demander de parcourir les colonnes C à V.

Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim SD As Variant 'déclare la variable SD (Sans Doublon)
Dim NO As Variant 'déclare la variable NO (Nombre d'Occurrences)

Set O = Sheets("Juillet") 'définit l'onglet O (à adapter)
DL = O.Cells(Application.Rows.Count, 9).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 2 (=B) de l'onglet O
Set PL = O.Range("I11:I" & DL) 'définit la plage PL
TC = PL 'définit le tableau de cellules TC
Set D = CreateObject("SCripting.Dictionary") 'définit le dictionnaire D
For I = 1 To UBound(TC, 1) 'boucle sur toutes les lignes I du tableau de cellues TC
    D(TC(I, 1)) = D(TC(I, 1)) + 1 'alimente le dictionnaire D
Next I 'prochaine ligne de la boucle
SD = D.keys 'récupère la liste sans doublon dans le tableau SD
NO = D.items 'récupère le nombre d'occurence de chaque élément de SD dans le tableau NO
Application.DisplayAlerts = False 'empêche les messages d'Excel (la fusion de plusieurs cellues éditées déclenche un message)
For I = 0 To UBound(NO, 1) 'boucle sur tous les éléments du tableau NO
    If NO(I) > 1 Then 'condition : si le nombre d'occurrences de l'élément de la boucle est supérieur à 1
        Set R = O.Columns(9).Find(SD(I), O.Cells(DL, 9), xlValues, xlWhole) 'recherche l'élément entier dans la colonne 2 (=B) de l'onglet O
        R.Resize(NO(I), 1).Merge 'redimensionne l'élément trouvé et le fusionne
    End If 'fin de la condition
Next I 'prochain élément du tableau NO
Application.DisplayAlerts = True 'affiche les messages d'Excel

    Application.ScreenUpdating = True

Pour supprimer, pour le moment, je n'arrive qu'à supprimer le contenu.

For I = [H65000].End(xlUp).Row To 2 Step -1
    If Cells(I, 8) = "H4" Then Rows(I).Delete
Next I

For I = [I65000].End(xlUp).Row To 2 Step -1
    If Cells(I, 9) Like "Suppr" Then Rows(I).Delete
Next I

Est-ce que vous pourriez m'aider à adapter tout ça ? Merci mille fois !

bonjour Emma87,

ce serait plus facile avec un fichier anonymisé ...

Uilisez ce icon ici dessus

Bonjour BsAlv,

Merci pour ton message ! Voici le fichier.

re,

on a les 2 macros "Fusionner" et "Defusionner", pour le moment, on voit encore ce qu'il se passe, mais plus tard, on blocquera l'écran pour augmenter la vitesse ...

PS. fusionner des cellules, je n'aime pas cela

Bonjour Bart,

Merci beaucoup pour ta réponse! Malheureusement, ce fichier est destiné à être utilisé via Sharepoint et je viens de me rendre compte qu'un fichier Excel ouvert dans Sharepoint ne prend pas en charge les macros. Il va donc falloir que je trouve une autre solution... Est-ce que tu sais comment faire pour "traduire" du VBA en un langage utilisable par les scripts de Sharepoint ?

re,

désolé mais je ne sais pas vous aider avec cela.

Ok, tant pis !

Je passe quand même le fil en résolu, merci pour ton aide !