XL 2013 Convertir des cases en couleurs (planning) en dates de début/Fin VBA

PMG

XLDnaute Junior
Bonjour à tous,

Je cherche à créer une macro pour transformer des données (case de couleurs) en plage Date de début / Date de fin.
Les cases sont colorées manuellement. Cette procédure me permet de comparer un planning théorique et réel.

J'ai écrit la procédure en texte, pourriez vous svp m'aider à l'écrire en VBA.
J'ai fais plusieurs essais, j'avance très lentement...

1/ Bouton sauvegarde (Shape)
2/ Tableau [F4:AC20]
3/ Colonne 1 (du tableau) = Dates
4/ Ligne 1 (du tableau) = Heures
5/ Recherche pour chaque cellule (i, j) du tableau [F4:AC20]
6/ SI Dates Colonne 1 >= Date d'enregistrement D29 ' Sinon pas d'enregistrement
7/ SI (Couleur cellule <> Rien ou Blanc) Alors Résultat1 = Code Couleur Cellule 'Code Couleur Excel
8/ SI (ET (Couleur cellule <> Rien ou Blanc ; Cellule -1 = Rien ou Blanc)) Alors Résultat2 = Date (Ligne i, Colonne 1) + Heure (Ligne 1, Colonne j) 'Format jj/mm/aa hh:mm
9/ SI (ET (Couleur cellule <> Rien ou Blanc ; Cellule + 1 = Rien ou Blanc)) Alors Resultat3 = Date (Ligne i, Colonne 1) + Heure (Ligne 1, Colonne j) 'Format jj/mm/aa hh:mm
10/ Résultat1 = 'Feuil2! 1ère Ligne vide trouvée, Colonne 1 ' Enregistrement 1ère ligne vide à la suite des autres (Historique)
11/ Résultat2 = 'Feuil2! 1ère Ligne vide trouvée, Colonne 2
12/ Résultat3 = 'Feuil2! 1ère Ligne vide trouvée, Colonne 3

Merci d'avance pour les personnes disponibles qui pourront m'aider à avancer dans ce casse tête!
PMG
A+
 

Pièces jointes

  • Couleurs vers dates.xlsm
    68.2 KB · Affichages: 15
Solution
Bonjour j'ai mis 30 parce qu'il y a 15 lignes avec 2 début/fin par ligne...
Oui F4 parce qu'il n'y a pas de couleur...
Pour sauvegarder à la suite
dim derlig as long
derlig=sheets("Sauvegarde").range("B"&rows.count).end(xlup).row+1
For i = 0 To lig
Sheets("Sauvegarde").Range("B" & i + derlig).Value = t_coul(i)
Sheets("Sauvegarde").Range("C" & i +derlig).Value = t_datedeb(i)
Sheets("Sauvegarde").Range("D" & i + derlig).Value = t_datefin(i)
Next
ne pas oublier d'enlever
Sheets("Sauvegarde").Range("B3:d5000").ClearContents

A+ François

PMG

XLDnaute Junior
Bonjour BrunoM45, fanfan38, le forum,
Merci pour vos réponses,

#fanfan38
Un très grand merci pour votre aide et temps consacré a ce problème.
Pourriez vous svp m'expliquer car j'aimerai comprendre:

1/ Dim t_coul(30), t_datedeb(30), t_datefin(30)
(30)? Nb de variables max.

2/ If Cells(i, j).Interior.Color <> Range("F4").Interior.Color
"F4"? Parce que pas de couleur dans cette cellule.

Pour l'enregistrement comment faire pour que les futurs valeurs a enregistrer n'effacent pas celles qui sont déjà sauvegardées, hormis celles à partir de la date d'enregistrement.

sheets("sauvegarde").Cells(.Rows.Count, 1).End(xlUp).Row + 1

1/Ancienne date d'enregistrement:
Range("D5") = 27/02/2020
2/Dates enregistrées:
Du 27/02/2020 au 09/03/2020
3/Nouvelle date d'enregistrement:
Range("D5") = 09/03/2020
4/Dates enregistrées à la suite des autres:
Du 09/03/2020 au XX/XX/2020

Votre macro est exactement ce que je cherchais à faire! Un grand merci!
PMG
A+
 

Pièces jointes

  • Copie de Couleurs vers dates 02.xlsm
    74.6 KB · Affichages: 2

fanfan38

XLDnaute Barbatruc
Bonjour j'ai mis 30 parce qu'il y a 15 lignes avec 2 début/fin par ligne...
Oui F4 parce qu'il n'y a pas de couleur...
Pour sauvegarder à la suite
dim derlig as long
derlig=sheets("Sauvegarde").range("B"&rows.count).end(xlup).row+1
For i = 0 To lig
Sheets("Sauvegarde").Range("B" & i + derlig).Value = t_coul(i)
Sheets("Sauvegarde").Range("C" & i +derlig).Value = t_datedeb(i)
Sheets("Sauvegarde").Range("D" & i + derlig).Value = t_datefin(i)
Next
ne pas oublier d'enlever
Sheets("Sauvegarde").Range("B3:d5000").ClearContents

A+ François
 

PMG

XLDnaute Junior
Bonjour François,

Merci bcp pour votre réponse et vos compétences, je mets le fichier modifié à disposition si cela intéresse qqun!

Bonne journée,
Paul
A+
 

Pièces jointes

  • Copie de Couleurs vers dates 03.xlsm
    34.2 KB · Affichages: 10

Discussions similaires

Réponses
13
Affichages
448
Réponses
2
Affichages
245
Haut Bas