Procédure trop grande
Bonjour à tous,
Je fais une application pour des jardiniers avec un planning semestriel qui reprend les semaines de semis/récolte. La macro se trouve en module 2.
Je peux reculer d'un semestre à l'autre pour 5 choix de légumes (Si vous cliquez sur la flêche < , macro "semestPréc" çà passe).
J'ai rajouté 40 autres cultures sur a macro "semestriel suivant" , et j'arrive à presque 1000 lignes pour la macro, et çà passe plus, (flêche >, macro "semestSuiv") avec le message:
J'ai lu quelques réponses sur le sujet pour réduire le code et diviser la macro, mais je vois pas trop comment faire.
Merci de votre aide.
Bonjour,
Place les deux procédures longues sur deux modules différents et lance-les depuis la macro d'origine
Bonjour M12,
Merci pour ta réponse rapide.
J'ai 2 macros, suivant et précédent, dans lesquelles j'ai 4 blocs de code assez long, et j'ai donc fait 4 modules pour la 1ere macro, pour voir.
Cà passe, mais çà n'éxécute pas les 4 modules, et y'a plus rien dans le tableau. :
drlig = 3
For i = 2 To drn2
'semaine semis et semaine récolte dans le semestre
If ((ws2.Range("E" & i).Value <= CSng(sema2) And Year(ws2.Range("D" & i).Value) = an) _
Or (ws2.Range("H" & i).Value >= CSng(sema1) And Year(ws2.Range("G" & i).Value) = an)) Then
For k = sema1 To sema2
If sema1 = 1 And (ws2.Range("E" & i).Value <= CSng(sema2) Or ws2.Range("H" & i).Value >= CSng(sema1)) _
And Year(ws2.Range("D" & i).Value) = an Then
'couleurs semis et récoltes 1er semestre (semaines 1 à 26)
Module1.resume1
'couleurs récoltes 1er semestre (semaines 1 à 26) semées au semestre précédent
Module4.resume2
'couleurs semis et récoltes 2eme semestre (semaines 27 à 52)
Module5.resume3
'couleurs semis 2eme semestre et récolte l'année suivante
Module6.resume4
End If
Next k
If ws1.Cells(drlig, 1).Value = "" Then GoTo there
If (ws2.Range("E" & i + 1).Value <= sema2 And ws2.Range("E" & i + 1).Value >= sema1 And _
Year(ws2.Range("D" & i + 1).Value) = an) Or (ws2.Range("H" & i + 1).Value >= sema1 _
And ws2.Range("H" & i + 1).Value <= sema2 And Year(ws2.Range("G" & i + 1).Value) = an) Then drlig = drlig + 1
End If
there:
Next iJe vais essayer de voir comment çà fonctionne.
A+
re,
je pense que la macro "Sub Nouv_Semestre(bSem)" fait le nécessaire ...
Bonjour BsAlv,
Wouah, génial, j'avais pas essayé çà alors.
Merci, je vais voir si je peux le faire avec la même mise en page.
Magnifique
re,
bonne chance, s'il y a encore des problèmes, il faut le dire ...
Bonjour BsAlv,
J'ai réussi à comprendre à peu prés ton code, mais il y a juste une erreur que je ne suis pas arrivé à corriger, c'est de mettre "1er Sem." et 2ème Sem aux 2 semestres.
Si tu pouvais voir çà.
Merci
re,
je prends F1, le lundi de la 2ème semaine, parce que la première est souvent dans un autre mois/année. Si le mois de cette date >6 (normallement on n'a que des dates en janvier ou juillet), on est dans le 2ème semestre. Si on veut le semestre suivant, alors c'est le 1 janvier de l'année suivant, si on veut le semestre précédent, c'est le 1 janvier de la même année, etc. Le fin de ce semestre + 1 jour = 6 mois plus tard et c'est la date "Nouv_Date2". Celle-là a peut-être donné de la confusion !
Puis on donne la valeur de cette année à la cellule A1. Même chose avec le semestre, mais là, je vois que j'ai pris "Nouv_Dat2", donc 6 mois après (!) et si cette date est en juillet, on est dans le premier semestre. C'était mieux compréhensible, si j'avais pris Nouv_Date (voir dernière ligne ici dessous) et si le mois est <7 = premier semestre, autrement deuxième semestre.
(Si cette date n'est pas un lundi, on prend le lundi précédent pour le mettre dans E1.)
.Range("A1").Value = Year(Nouv_Date)
.Range("A2").Value = IIf(Month(Nouv_Date2) = 7, 1, 2) & "ème Sem." '---> avec Nouv_Date2
.Range("A2").Value = IIf(Month(Nouv_Date) < 7, 1, 2) & "ème Sem." '---> même chose mais avec Nouv_Date
mais peut-être vous ne voulez pas cette explication, simplement ceci
.Range("A2").Value = IIf(Month(Nouv_Date) < 7, "1er", "2ème" ) & " Sem." '---> même chose mais avec Nouv_DateConcernant les semaines, j'ai utilisé le système d' "ISO.SEMAINE" qu'on utilise en Europe et la majorité du monde et ne pas le système américain.
Ok çà marche maintenant 1er et 2éme Sem.
Ton travail pour recadrer correctement les dates sur les bonnes semaines est super
Par contre, les flêches ne font plus apparaitre les nouvelles cultures enregistrées au 1er semestre 2023, les 2 1eres lignes.
Merci
re,
pour ces 2 lignes, 3 des 4 dates sont format "texte", donc ce ne sont pas vraiment des dates. Vous utilisez ces dates encore ailleurs ?
Pour moi, c'est facile pour adapter ma macro qu'elle fonctionne aussi avec de textes, mais si cela cause aussi d'autres problèmes, c'est peut-être plus facile à éviter ce type de données ?
re,
D2:D3 sont encore des dates sous forme de "texte" et la macro les transforme comme date. Ces colonnes ont une validation pour le moment.
Bonjour à tous,
Effectivement c'était de ma faute j'ai pas mis le bon format CDate(Format(Me.datA.Value, "dd/mm/yy")) en enregistrement/ modif.
Maintenant çà apparait dans le semestre.
Merci BsAlv
Par contre ce que tu as rajouté là ne permet pas de garder les couleurs de la police, qui a parfois besoin d'être en blanc (noir sur noir on voit rien).
If B Then
R = Application.Match(ab(i, 2), Sheets("Listes").Range("G1:G100"), 0)
If IsNumeric(R) Then
.Cells(ptr, 5).Resize(, UBound(aA)).SpecialCells(xlConstants).Interior.Color = Sheets("listes").Cells(R, "G").Interior.Color
End If
End IfDésolé
re,
Quelque lignes plus haut, en cas que la culture ou l'abrégé est inconnu, on a ceci (cela ne cause pas votre problème, je suppose)
If ab(i, 4) <= Nouv_Date2 And Nouv_Date <= ab(i, 7) Then
If ab(i, 3) = "" Then ab(i, 3) = "???" 'abrégé inconnu
If ab(i, 2) = "" Then ab(i, 2) = "???" 'culture inconnu
.Cells(ptr, 1) = ab(i, 2) 'nom culture
Puis votre problème est que la culture de votre ligne est inconnue dans la colonne G de "Listes", parce que c'est là que je prend les couleurs. Si vous ne voulez pas ce "noir", alors supprimer ce "else" comme vous l'avez fait, mais mieux, c'est d'ajouter cette culture dans la colonne G. Ajouter une sorte de validation avec cette colonne G sur la colonne B de "Cultures" est malin.
If B Then 'boolean = pour savoir s'il y a des cultures entre colonne E:AE de cette ligne
R = Application.Match(ab(i, 2), Sheets("Listes").Range("G1:G100"), 0) 'cherchez cette culture dans la colonne G de "liste"
If IsNumeric(R) Then 'culture connue
.Cells(ptr, 5).Resize(, UBound(aA)).SpecialCells(xlConstants).Interior.Color = Sheets("listes").Cells(R, "G").Interior.Color
Else 'culture inconnue
.Cells(ptr, 5).Resize(, UBound(aA)).SpecialCells(xlConstants).Interior.ColorIndex = 1
End If
End IfPuis votre problème est que la culture de votre ligne est inconnue dans la colonne G de "Listes"
C'est faux. Les cultures sont toutes en colonne G en "listes".
Les couleurs de fond sont reproduites mais pas la police en blanc, exemple pour l'aubergine ou la courgette, que j'ai mis en "Cultures" et apparait en "Semestriel".
Il faudrait CRG écrit en blanc.
j'ai ajouté le couleur de la police.
Bonjour Bsalv,
Je reviens vers toi aprés ton super boulot sur la macro rapide de l'onglet semestriel.
C'est la macro Sub Nouv_Semestre(bSem) dans le module9
Maintenant que je me penche dessus, je réalise l'exercice que je dois en faire.
Sub Nouv_Semestre(bSem)
'***********************************************************************************
'résultat sera le semestre précédent ou prochain dépendant du variable bSem, True=prochain, False=précédent)
'***********************************************************************************
Dim MaDate, Nouv_Date, Nouv_Date2, iSem, aA
Dim ws1 As Worksheet
Set ws1 = Sheets("Semestriel")
With Sheets("Semestriel")
MsgBox Date
With .Range("F1") 'date de la 2ème semaine du semestre actuel, premiere semaine n'est pas toujours dans le même mois/année
If .Value = "" Then 'si vide = prenez semestre de maintenant
.Value = DateSerial(Year(Date), ((Month(Date) - 1) Mod 6) * 6 + 1, 1)
'1/01 => (Month(Date) - 1) Mod 6) * 6 + 1 donne (0 x 6) + 1 =1
'1/07 => ((Month(Date) - 1) Mod 6) * 6 + 1 donne (1 x 6) + 1= 7
End If
MaDate = .Value2 ' ?
End With
'prochain semestre
If bSem Then
If Month(MaDate) > 6 Then
Nouv_Date = DateSerial(Year(MaDate) + 1, 1, 1) '1ier janvier l'année prochaine
Else
Nouv_Date = DateSerial(Year(MaDate), 7, 1) '1ier juillet de cette année
End If
Else 'semestre précedent
If Month(MaDate) > 6 Then
Nouv_Date = DateSerial(Year(MaDate), 1, 1) '1ier janvier de cette année
Else
Nouv_Date = DateSerial(Year(MaDate) - 1, 7, 1) '1ier juillet de l'année précédent
End If
End If 'dates 2eme semestre
Nouv_Date2 = CDbl(WorksheetFunction.EDate(Nouv_Date, 6)) '+ 6 mois =EDATE (Start_date, Months) 6/07 apres 6/01 en avançant
.Range("A1").Value = Year(Nouv_Date) 'année
.Range("A2").Value = IIf(Month(Nouv_Date) < 7, "1er", "2ème") & " Sem."
Nouv_Date = CDbl(Nouv_Date - Weekday(Nouv_Date, 2) + 1) 'le lundi précédent en cas que ce n'est pas un lundi
'lundi le premier jour de la semaine Weekday(Nouv_Date, 2)
iSem = (Nouv_Date2 - Nouv_Date - 1) \ 7 + 1 '(/7) + 1 revient au nombre de semaines
'tous les lundis
ReDim aA(1 To iSem)
For i = 1 To iSem
aA(i) = Nouv_Date + (i - 1) * 7 'date + n° semaine (de 1 à 26) x 7
Next
With .Range("E1")
.Resize(2, 30).ClearContents 'marge de 3 apres S27
.Resize(, iSem).Value = aA
.Resize(, iSem).Offset(1).FormulaR1C1 = "=IF(R[-1]C<>"""",ISOWEEKNUM(R[-1]C),""-"")" 'iso-semaines
End With
.Range("A1").CurrentRegion.Offset(2).Clear 'efface à partir de la ligne 3
.Range("C1").Resize(, 2).EntireColumn.NumberFormat = "ddd dd-mm"
'tableau Cultures
ab = Range("Tableau2").Value2
ptr = 3
For i = 1 To UBound(ab)
If ab(i, 4) <= Nouv_Date2 And Nouv_Date <= ab(i, 7) Then
.Cells(ptr, 1) = ab(i, 2) 'nom culture
.Cells(ptr, 2) = ab(i, 1) 'num parcelle
.Cells(ptr, 3) = ab(i, 4) 'date semis
.Cells(ptr, 4) = ab(i, 7) 'date récolte
B = False
For j = 1 To UBound(aA)
If ab(i, 4) <= aA(j) + 6 And aA(j) <= ab(i, 7) Then .Cells(ptr, j + 4).Value = ab(i, 3): B = True
Next
''boolean = pour savoir s'il y a des cultures entre colonne E:AE de cette ligne
If B Then
R = Application.Match(ab(i, 2), Sheets("Listes").Range("G1:G100"), 0)
If IsNumeric(R) Then 'culture connue
.Cells(ptr, 5).Resize(, UBound(aA)).SpecialCells(xlConstants).Interior.Color = Sheets("listes").Cells(R, "G").Interior.Color
.Cells(ptr, 5).Resize(, UBound(aA)).SpecialCells(xlConstants).Font.Color = Sheets("listes").Cells(R, "G").Font.Color 'la police
Else
.Cells(ptr, 5).Resize(, UBound(aA)).SpecialCells(xlConstants).Font.ColorIndex = 2 'police blanc
End If
End If
ptr = ptr + 1
End If
NextJ'ai réussit à comprendre dans les grandes lignes, mais voici mes questions:
C'est quoi bsem et pkoi déclarer ici plutôt qu'en Dim, et sans%, $.. aprés
If bSem ThenDate en msgbox c'est la date du jour, elle est paramétrée ou ? et si on avance de 2 semestres, elle sert plus à rien.
.Value = DateSerial(Year(Date), ((Month(Date) - 1) Mod 6) * 6 + 1, 1)
'1/01 => (Month(Date) - 1) Mod 6) * 6 + 1 donne (0 x 6) + 1 =1
'1/07 => ((Month(Date) - 1) Mod 6) * 6 + 1 donne (1 x 6) + 1= 7.value2 c'est le format chiffre
isem c'est une variable en date ?
Resize c'est comme redim ?
Le controle numérique pour du texte, pkoi ?
R = Application.Match(ab(i, 2), Sheets("Listes").Range("G1:G100"), 0)
If IsNumeric(R) Then 'culture connueEt pourquoi j + 4 pour mettre l'abrégé (ou réf) dans le planning.
For j = 1 To UBound(aA)
If ab(i, 4) <= aA(j) + 6 And aA(j) <= ab(i, 7) Then .Cells(ptr, j + 4).Value = ab(i, 3): B = True
NextMerci
bonjour,
Ces flèches de la cellule A1 de la feuille "semestre" sont assignés aux macros semestrPrec() et semestrSuiv() qui sont les mêmes sauf leur paramètre, il sautent vers la macro "Nouv_Semestre" avec le paramètre "True" ou "False", ce paramètre "bSem" dans l'entête. Plus d'explication : voir https://www.excel-pratique.com/fr/vba/procedures_fonctions. Déclarer les variables est une bonne habitude quand on débute en VBA, mais c'est un choix personnel, après autant d'années, moi, je ne le fais plus. Si vous voulez le faire, il faut modifier le début de la macro Nouv_Semestre comme ça Sub Nouv_Semestre(bSem as boolean), je ne trouve pas ce "pkol".
Dim MaDate, Nouv_Date, Nouv_Date2, iSem, aA : ils sont du type variant, parce que je n'avais rien ajouter = la même choice que faire rien, paresseux, .... %, $, ... sont des symboles anciens, que je n'utilise pas. La ligne des déclarations serait possible comme ca (ou en plusieurs lignes)
Dim MaDate As Date, Nouv_Date As Date, Nouv_Date2 As Date, iSem As Integer, aA As Variant, i As Integer, aB As Variant, ptr As Integer, b As Boolean, j As Integer, r As Variant, DrLig As LongNow et Date sont les mêmes valeurs en VBA que les formules MAINTENANT() et AUJOURDHUI() qu'on utilise dans ces feuilles
Sub Aujourdhui()
MsgBox "Aujourd'hui : " & Format(Date, "dddd dd-mmm-yyyy")
MsgBox "Maintenant : " & Format(Now, "dddd dd-mm-yyyy hh:mm:ss")
End Subla construction "((Month(Date) - 1) Mod 6) * 6 + 1", on est le 11 mai = 5ième mois alors (5-1) mod 6 = 4 mod 6 = 0 et puis 0*6+1 = 1 donc janvier. Si on était en septembre = 9ième mois ----> ((9-1) mod 6) *6 + 1 = (8 mod 6) * 6 + 1 = 1 * 6 + 1 = 7 = juillet
".value2", c'est pour lire des données sans fautes, sans arrondir pour des valeurs "currency" ou dates. Supposons qu'une cellule contient une valeur de "1234,56789" mais le format de la cellule est "0,00 €", on risque d'ajouter la valeur arrondi "1.234,57" au tableau, dépendant de la situation cela n'est pas préférable. La même chose avec les dates ou dates+heures, Excel est d'origine américain et utilise le format "MM/DD/YYYY". En utilisant ".value2", on lit toujours correct. Donc pour tous les autres situations, il n'y a pas de différence entre ".value" et ".value2", mais pour des valeurs "currency" et "dates", je préfère utiliser "Value2".
iSem est un integer = le nombre de semaines dans votre tremestre avec une correction pour le début du tremestre, si le premier n'est pas un lundi, on recule jusqu'au lundi précédent, pour avoir des semaines complèts. Par exemple 1/7/2023 est samedi, le lundi précédent = 26/6/23
Resize est pour définir une plage dans une feuille, voir https://learn.microsoft.com/fr-fr/office/vba/api/excel.range.resize, redim est pour redimensioner un array en mémoire, donc c'est semblable mais pas égal !!!
pkoi ???
R = Application.Match(ab(i, 2), Sheets("Listes").Range("G1:G100"), 0)c'est important que R est du type variant et certainement pas integer ou long, alors VBA a le choix d'assigner une valeur "erreur" à R, si le match ne donne pas un résultat.
aA = un tableau avec tous les dates "lundi" du semestre, par exemple 2ieme semestre 2023 = 26/6/23, 3/7/2023,10/7/23, ...., 25/12/2023. Le premier élément de "aA" = première semaine = correspond à la 5ième colonne "E" de "Semestre" (les colonnes A:D sont culture, parcelle, date semis, date réculte), donc c'est pourquoi on ajoute 4.
Bonjour,
Merci pour les explications.
pkoi c'est du langage sms pour dire pourquoi.
donc le controle numérique pour du texte, pourquoi ?
R = Application.Match(ab(i, 2), Sheets("Listes").Range("G1:G100"), 0)
If IsNumeric(R) Then 'culture connueSinon, date est toujours 1 quand on passe au 2ème semestre avec
.Value = DateSerial(Year(Date), ((Month(Date) - 1) Mod 6) * 6 + 1, 1)parce qu'on est toujours en mai.
Cdt
re,
aB = un tableau en mémoire et donc une copie virtuelle du tableau "Tableau2" de la feuille "Culture". La 2ième colonne de ce tableau sont les cultures.
Colonne G de la feuile "Liste" sont les mêmes noms de culture avec leur couleur correspondant.
Si on trouve un match exact, R représente la ligne du nom de culture dans "Liste", par exemple "pomme de terre" sera 35, (parce que G35=pomme de terre). Si le nom est inconnu dans la colonne G, R est type variant/error avec valeur "Fout 2042", en français "Erreur 2042", ce valeur n'est pas numérique, donc les couleurs Colorindex seront 1 et 2
Si F1 de la feuille "Semestriel" est vide, on prendra pour aujourd'hui le 01/01/2023, donc semestre 1 de 2023 pour date de début "MaDate",ce F1 n'est pas vide, MaDate sera la valeur de F1. Pourquoi la cellule F1 et pas E1, E1 est le lundi précédent, si le premier n'était pas un lundi, donc E1 n'est pas nécessairement dans le même semestre/année que G1. Donc F1 est le "vrai premier lundi" de ce semestre et ne pas nécessairement le premier du mois.
With Sheets("Semestriel")
With .Range("F1") 'date de la 2ème semaine du semestre actuel, premiere semaine n'est pas toujours dans le même mois/année
If .Value = "" Then 'si vide = prenez semestre de maintenant
.Value = DateSerial(Year(Date), ((Month(Date) - 1) Mod 6) * 6 + 1, 1)
'Quand on appui la flèche gauche ou droite, ce fameux "bSem" avec valeur "Vrai" ou "Faux", on soustrait ou ajoute 6 mois et si le semestre actuel est 1 ou 2, on a les 4 possibilités ici dessous ... pour calculer "Nouv_date" et les règles suivants pour calculer le lundi précédent.
If bSem Then
If Month(MaDate) > 6 Then
Nouv_Date = DateSerial(Year(MaDate) + 1, 1, 1) '1ier janvier l'année prochaine
Else
Nouv_Date = DateSerial(Year(MaDate), 7, 1) '1ier juillet de cette année
End If
Else 'semestre précedent
If Month(MaDate) > 6 Then
Nouv_Date = DateSerial(Year(MaDate), 1, 1) '1ier janvier de cette année
Else
Nouv_Date = DateSerial(Year(MaDate) - 1, 7, 1) '1ier juillet de l'année précédent
End If
End If