Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel DATE et calendrier depuis une table de données

DATE et calendrier depuis une table de données

9 réponses
Avatar
loic.andre73
re bonsoir=20

je reviens avec mon probleme de date dans un calendrier=20

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

en fait, sur l'exemple du site, il part d'un calendrier ou il rempli des do=
nn=E9es =E0 l'aide de liste d=E9roulante et dans une feuille il r=E9cup=E8r=
e la synth=E8se.=20

je souhaiterai partir de la feuille dite de synth=E8se 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=20

voici le lien pour mieux comprendre=20

http://cjoint.com/?DLpxgPMuocj=20

merci par avance=20
Signaler un problème avec ce contenu

9 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
isabelle
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

Avatar
loic.andre73
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
>
Avatar
isabelle
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
Avatar
loic.andre73
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
Avatar
isabelle
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
Avatar
isabelle
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
Avatar
isabelle
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
Avatar
isabelle
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
Avatar
loic.andre73
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