DATE et calendrier depuis une table de données

Le
loic.andre73
re bonsoir

je reviens avec mon probleme de date dans un calendrier

j'ai trouvé sur le site de jacques boisgontier un exemple mais celui ci m=
arche à l'inverse de ce que je souhaiterai

en fait, sur l'exemple du site, il part d'un calendrier ou il rempli des do=
nnées à l'aide de liste déroulante et dans une feuille il récupèr=
e la synthèse.

je souhaiterai partir de la feuille dite de synthèse ou je rentre mes dat=
es et que celle ci me genre un calendrier en colorant les cellules en fonct=
ion de la date et du domaine choisi

voici le lien pour mieux comprendre

http://cjoint.com/?DLpxgPMuocj

merci par avance
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
isabelle
Le #26329518
bonjour ,

ta macro commence par effacer les données
[A2:c1000].ClearContents
alors il ne reste plus de données à transférer

isabelle


Le 2014-12-16 14:00, a écrit :
re bonsoir

je reviens avec mon probleme de date dans un calendrier

j'ai trouvé sur le site de jacques boisgontier un exemple mais celui ci marche


l'inverse de ce que je souhaiterai

en fait, sur l'exemple du site, il part d'un calendrier ou il rempli des données


à l'aide de liste déroulante et dans une feuille il récupère la synthèse.

je souhaiterai partir de la feuille dite de synthèse ou je rentre mes dates


et que celle ci me genre un calendrier en colorant les cellules en fonction de
la date et du domaine choisi

voici le lien pour mieux comprendre

http://cjoint.com/?DLpxgPMuocj

merci par avance

loic.andre73
Le #26329537
bonsoir isabelle

oui effectivement

je n'ai rien touché aux macros de jacques, je voulais juste montrer ce qu e je souhaitais faire

partir d'une liste avec des dates pour que l'entête ( C1, C2 etc ) soit r eportée dans mon calendrier

et non l'inverse comme sir boisgontier le fait

Le mardi 16 décembre 2014 20:25:09 UTC+1, isabelle a écrit :
bonjour ,

ta macro commence par effacer les données
[A2:c1000].ClearContents
alors il ne reste plus de données à transférer

isabelle


Le 2014-12-16 14:00, a écrit :
> re bonsoir
>
> je reviens avec mon probleme de date dans un calendrier
>
> j'ai trouvé sur le site de jacques boisgontier un exemple mais celui ci marche
l'inverse de ce que je souhaiterai
>
> en fait, sur l'exemple du site, il part d'un calendrier ou il rempli de s données
à l'aide de liste déroulante et dans une feuille il récupère la s ynthèse.
>
> je souhaiterai partir de la feuille dite de synthèse ou je rentre mes dates
et que celle ci me genre un calendrier en colorant les cellules en foncti on de
la date et du domaine choisi
>
> voici le lien pour mieux comprendre
>
> http://cjoint.com/?DLpxgPMuocj
>
> merci par avance
>
isabelle
Le #26329548
voilà,

Sub transfert()
Dim i As Long

Set f1 = Sheets("SynthèseBD")
Set f2 = Sheets("PlanSem1")
[ChampMFC].ClearContents
lastrow = Cells(Cells.Rows.Count, 1).End(xlUp).Row

For i = 2 To lastrow
On Error Resume Next
If Not IsError(Application.Match(f1.Range("A" & i))) Or Not
IsError(Application.Match(CDbl(f1.Cells(i, 2)))) Then
rw = Application.Match(f1.Range("A" & i), f2.Range("A:A"), 0)
clm = Application.Match(CDbl(f1.Cells(i, 2)), f2.Range("3:3"), 0)
f2.Cells(rw, clm) = f1.Cells(i, 3)
End If
Next

End Sub

pour les couleurs je te suggère de faire une mfc sur la plage ChampMFC

isabelle
loic.andre73
Le #26329555
waou chapeau

merci isabelle

mais ce code je le place sur quelle feuille car il y en a deja notamment da ns les worksheet change et je ne voudrai pas tout casser

si tu as le modele qui t'a servi à réaliser cela je suis preneur

merci encore

Le mardi 16 décembre 2014 22:51:15 UTC+1, isabelle a écrit :
voilà,

Sub transfert()
Dim i As Long

Set f1 = Sheets("SynthèseBD")
Set f2 = Sheets("PlanSem1")
[ChampMFC].ClearContents
lastrow = Cells(Cells.Rows.Count, 1).End(xlUp).Row

For i = 2 To lastrow
On Error Resume Next
If Not IsError(Application.Match(f1.Range("A" & i))) Or Not
IsError(Application.Match(CDbl(f1.Cells(i, 2)))) Then
rw = Application.Match(f1.Range("A" & i), f2.Range("A:A"), 0)
clm = Application.Match(CDbl(f1.Cells(i, 2)), f2.Range("3:3"), 0)
f2.Cells(rw, clm) = f1.Cells(i, 3)
End If
Next

End Sub

pour les couleurs je te suggère de faire une mfc sur la plage ChampMFC

isabelle
isabelle
Le #26329575
tu mets la macro dans un module standard
et tu peut appeler cette macro à partir de n'importe quel autre macro de ton
choix, événementiel ou non
par la commande :
Call transfert

isabelle

Le 2014-12-16 16:53, a écrit :

waou chapeau

merci isabelle

mais ce code je le place sur quelle feuille car il y en a deja notamment dans les worksheet change et je ne voudrai pas tout casser

si tu as le modele qui t'a servi à réaliser cela je suis preneur

merci encore

Le mardi 16 décembre 2014 22:51:15 UTC+1, isabelle a écrit :
voilà,

Sub transfert()
Dim i As Long

Set f1 = Sheets("SynthèseBD")
Set f2 = Sheets("PlanSem1")
[ChampMFC].ClearContents
lastrow = Cells(Cells.Rows.Count, 1).End(xlUp).Row

For i = 2 To lastrow
On Error Resume Next
If Not IsError(Application.Match(f1.Range("A" & i))) Or Not
IsError(Application.Match(CDbl(f1.Cells(i, 2)))) Then
rw = Application.Match(f1.Range("A" & i), f2.Range("A:A"), 0)
clm = Application.Match(CDbl(f1.Cells(i, 2)), f2.Range("3:3"), 0)
f2.Cells(rw, clm) = f1.Cells(i, 3)
End If
Next

End Sub

pour les couleurs je te suggère de faire une mfc sur la plage ChampMFC

isabelle
isabelle
Le #26329583
il faudrait modifier la ligne suivante,

lastrow = Cells(Cells.Rows.Count, 1).End(xlUp).Row

par,

With f1
lastrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With

isabelle
isabelle
Le #26329590
j'ai ajouté la couleur,

Sub transfert()
Dim i As Long, rw As Long

Set f1 = Sheets("SynthèseBD")
Set f2 = Sheets("PlanSem1")
Set f3 = Sheets("Couleurs")

[ChampMFC].ClearContents

With f1
lastrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With

For i = 2 To lastrow
On Error Resume Next
If Not IsError(Application.Match(f1.Range("A" & i))) Or Not
IsError(Application.Match(CDbl(f1.Cells(i, 2)))) Then
rw = Application.Match(f1.Range("A" & i), f2.Range("A:A"), 0)
clm = Application.Match(CDbl(f1.Cells(i, 2)), f2.Range("3:3"), 0)
f2.Cells(rw, clm) = f1.Cells(i, 3)
f2.Cells(rw, clm).Interior.Color = f3.Cells(Application.Match(f1.Range("C"
& i), f3.Range("A:A"), 0), 2)
End If
Next

End Sub

isabelle
isabelle
Le #26329596
ou plutôt enlever et remettre les format,

Sub transfert()
Dim i As Long, rw As Long

Set f1 = Sheets("SynthèseBD")
Set f2 = Sheets("PlanSem1")
Set f3 = Sheets("Couleurs")

[ChampMFC].ClearContents
[ChampMFC].ClearFormats
Application.ScreenUpdating = False

With f1
lastrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With

For i = 2 To lastrow
On Error Resume Next
If Not IsError(Application.Match(f1.Range("A" & i), f2.Range("A:A"), 0)) Or
Not IsError(Application.Match(CDbl(f1.Cells(i, 2)), f2.Range("3:3"), 0)) Then
rw = Application.Match(f1.Range("A" & i), f2.Range("A:A"), 0)
clm = Application.Match(CDbl(f1.Cells(i, 2)), f2.Range("3:3"), 0)
f2.Cells(rw, clm) = f1.Cells(i, 3)
f2.Cells(rw, clm).Interior.Color = f3.Cells(Application.Match(f1.Range("C"
& i), f3.Range("A:A"), 0), 2)
End If
Next

For y = 1 To 4
With [ChampMFC].Borders(y)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
Next

Application.ScreenUpdating = True
End Sub


isabelle
loic.andre73
Le #26329775
Merci beaucoup isabelle

je vais adapter tout cela à mon projet

bonnes fetes


Le mercredi 17 décembre 2014 08:20:30 UTC+1, isabelle a écrit :
ou plutôt enlever et remettre les format,

Sub transfert()
Dim i As Long, rw As Long

Set f1 = Sheets("SynthèseBD")
Set f2 = Sheets("PlanSem1")
Set f3 = Sheets("Couleurs")

[ChampMFC].ClearContents
[ChampMFC].ClearFormats
Application.ScreenUpdating = False

With f1
lastrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With

For i = 2 To lastrow
On Error Resume Next
If Not IsError(Application.Match(f1.Range("A" & i), f2.Range("A:A"), 0)) Or
Not IsError(Application.Match(CDbl(f1.Cells(i, 2)), f2.Range("3:3"), 0)) Then
rw = Application.Match(f1.Range("A" & i), f2.Range("A:A"), 0)
clm = Application.Match(CDbl(f1.Cells(i, 2)), f2.Range("3:3"), 0)
f2.Cells(rw, clm) = f1.Cells(i, 3)
f2.Cells(rw, clm).Interior.Color = f3.Cells(Application.Match(f1.R ange("C"
& i), f3.Range("A:A"), 0), 2)
End If
Next

For y = 1 To 4
With [ChampMFC].Borders(y)
.LineStyle = xlContinuous
.Weight = xlHairline
End With
Next

Application.ScreenUpdating = True
End Sub


isabelle
Publicité
Poster une réponse
Anonyme