Mirguy23
XLDnaute Nouveau
Bonjour à tous,
Je me retrouve confronter un petit problème lors de la synthèse de toute mes feuilles et j'espère que vous pourrez m'aider .
Contexte:
J'ai plusieurs feuilles dans un même fichier, en totale 7 feuilles..
- Six feuilles qui contiennent des données différentes et la septième est la feuille ou la macro vient faire la synthèse de toute les feuilles.
Difficulté:
J'ai rajouté des données sur d'autres feuilles, et les informations ajoutées n'apparaissent pas dans la feuille que s'effectue la synthèse. C'est toujours la même synthèse.
J'ai tenté des trucs mais je n'y suis pas du tout. Je vous mets tout de même les lignes de codes de ma macro mais je suis preneur de toute proposition
.
Le lien pour le fichier
https://www.cjoint.com/c/IFAoBUIqcUN
Je me retrouve confronter un petit problème lors de la synthèse de toute mes feuilles et j'espère que vous pourrez m'aider .
Contexte:
J'ai plusieurs feuilles dans un même fichier, en totale 7 feuilles..
- Six feuilles qui contiennent des données différentes et la septième est la feuille ou la macro vient faire la synthèse de toute les feuilles.
Difficulté:
J'ai rajouté des données sur d'autres feuilles, et les informations ajoutées n'apparaissent pas dans la feuille que s'effectue la synthèse. C'est toujours la même synthèse.
J'ai tenté des trucs mais je n'y suis pas du tout. Je vous mets tout de même les lignes de codes de ma macro mais je suis preneur de toute proposition
Le lien pour le fichier
https://www.cjoint.com/c/IFAoBUIqcUN
VB:
Option Explicit
Sub AfficherDelais(ByVal ligneRes As Integer, ByVal delai As Single)
Dim dateLiv As Date, today As Date
Dim retard As Single
today = Date
If ligneRes > 0 Then
With shSynthese
dateLiv = CDate(.Cells(ligneRes, 18))
retard = CInt((today - dateLiv + delai) * 10) / 10
delai = CInt(10 * delai) / 10
.Cells(ligneRes, 27) = delai & " jrs"
If retard > 0 Then
.Cells(ligneRes, 28).Value = retard & " jrs"
.Cells(ligneRes, 28).Font.Color = RGB(255, 0, 0)
End If
.Range("R" & ligneRes & ":AB" & ligneRes).Borders(xlEdgeTop).LineStyle = xlDash
End With 'shSynthese
End If
End Sub
Function GetInfosCC(ByRef CC As String, ByVal tpsRestant As Single, ByRef tpsAttente As Single) As Single
Dim ligne As Integer
ligne = 1
With shCC
'TQ on a pas trouvé le centre de charge mais qu'il reste des lignes
While .Cells(ligne, 1).Value <> CC And .Cells(ligne, 1).Value <> ""
ligne = ligne + 1
Wend 'Fin TQ on a pas trouvé le centre de charge
'Si on a trouvé le centre de charge
If .Cells(ligne, 1).Value = CC Then
tpsAttente = .Cells(ligne, 3)
'Si on a pas de capacité (sous-traitance)
If .Cells(ligne, 8) = "" Then
GetInfosCC = 0
Else
GetInfosCC = tpsRestant / .Cells(ligne, 8)
End If 'Fin si on a pas de capacité
Else
tpsAttente = 0
GetInfosCC = 0
End If 'Fin si on a trouvé le centre de charge
End With 'shCC
End Function
Private Sub CheckChk()
If chkCC.Value = True And chkCommandes.Value = True And chkOA.Value = True And chkOF.Value = True And chkOFMontage.Value = True Then
chkTout.Value = True
ElseIf chkCC.Value = False And chkCommandes.Value = False And chkOA.Value = False And chkOF.Value = False And chkOFMontage.Value = False Then
chkTout.Value = False
Else
chkTout.Value = Null
End If
End Sub
Private Sub chkCC_Click()
Call CheckChk
End Sub
Private Sub chkCommandes_Click()
Call CheckChk
End Sub
Private Sub chkOA_Click()
Call CheckChk
End Sub
Private Sub chkOF_Click()
Call CheckChk
End Sub
Private Sub chkOFMontage_Click()
Call CheckChk
End Sub
Private Sub chkTout_Click()
Dim etat As Boolean
etat = chkTout.Value
chkCC.Value = etat
chkCommandes.Value = etat
chkOA.Value = etat
chkOF.Value = etat
chkOFMontage = etat
End Sub
Function CopyOA(projet, article, ByVal ligneRes As Integer, OA As Integer)
Dim lastTop(5)
Dim res As Range
Dim firstAddress As String
Dim ligneOA As Long
Dim colOA As Integer
'nb d'OA correspondants à la commande
OA = 0
'Application.ScreenUpdating = False
With shOA
Set res = .Range("B:B").Find(What:=article, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
:=False, SearchFormat:=False)
If Not res Is Nothing Then
firstAddress = res.Address
Do
ligneOA = res.Row
If .Cells(ligneOA, 1) = projet And res.Value = article Then
For colOA = 3 To 7
If OA = 0 Or .Cells(ligneOA, colOA).Value <> lastTop(colOA - 2) Then
shSynthese.Cells(ligneRes, colOA + 26).Value = .Cells(ligneOA, colOA).Value
lastTop(colOA - 2) = .Cells(ligneOA, colOA).Value
End If
Next colOA
OA = OA + 1
ligneRes = ligneRes + 1
End If
Set res = .Range("B:B").FindNext(After:=res)
Loop While Not res Is Nothing And res.Address <> firstAddress
End If
End With 'shOA
If OA > 0 Then
With shSynthese.Range("AC" & ligneRes - OA & ":AG" & ligneRes - 1)
'bordure épaisse :
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
'couleur de cellules : blanc
.Interior.Color = RGB(255, 255, 255)
End With 'shSynthese.Range("AC" & ligneRes - oa & ":AG" & ligneRes - 1)
End If
End Function
Function CopyOF(projet, article, ByVal ligneRes As Integer, of As Integer)
Dim lastTop(14)
Dim nbTabOF As Integer
Dim res As Range
Dim delai As Single, tpsAttente As Single, capacite As Single
Dim firstAddress As String
Dim ligneDebut As Long, ligneOF As Long
Dim colOF As Integer
'nb d'OF correspondants à la commande
of = 0
ligneDebut = 0
With shOF
Set res = .Range("B:B").Find(What:=article, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
:=False, SearchFormat:=False)
If Not res Is Nothing Then
firstAddress = res.Address
Do
ligneOF = res.Row
'Si la ligne d'OF correspond
If .Cells(ligneOF, 1) = projet And res.Value = article Then
'Si même OF
If .Cells(ligneOF, 4) = lastTop(2) Then
delai = delai + tpsAttente 'Ajout du temps d'attente précédent
delai = delai + GetInfosCC(.Cells(ligneOF, 8), .Cells(ligneOF, 10) - .Cells(ligneOF, 11), tpsAttente)
For colOF = 3 To 11
'Si un nouvel OF
If colOF > 7 Or of = 0 Or .Cells(ligneOF, colOF).Value <> lastTop(colOF - 2) Then
shSynthese.Cells(ligneRes, colOF + 15).Value = .Cells(ligneOF, colOF).Value
lastTop(colOF - 2) = .Cells(ligneOF, colOF).Value
'On enregistre l'OF
ReDim tabOF(nbTabOF + 1)
tabOF(nbTabOF) = .Cells(ligneOF, 4).Value
nbTabOF = nbTabOF + 1
End If 'Fin si un nouvel OF
Next colOF
Else
For colOF = 3 To 11
'On réaffiche toutes les informations
shSynthese.Cells(ligneRes, colOF + 15).Value = .Cells(ligneOF, colOF).Value
lastTop(colOF - 2) = .Cells(ligneOF, colOF).Value
'On enregistre l'OF
ReDim tabOF(nbTabOF + 1)
tabOF(nbTabOF) = .Cells(ligneOF, 4).Value
nbTabOF = nbTabOF + 1
'Fin si un nouvel OF
Next colOF
'Si on a déjà fait un OF avant :
If ligneDebut <> 0 Then
Call AfficherDelais(ligneDebut, delai)
End If 'Fin si on a déjà fait un OF avant
ligneDebut = ligneRes
delai = GetInfosCC(.Cells(ligneOF, 8), .Cells(ligneOF, 10) - .Cells(ligneOF, 11), tpsAttente)
End If 'Fin si même OF
'Si sous-traitance
If .Cells(ligneOF, 12) <> "" Then
For colOF = 12 To 16
If of = 0 Or .Cells(ligneOF, colOF).Value <> lastTop(colOF - 2) Then
shSynthese.Cells(ligneRes, colOF + 17).Value = .Cells(ligneOF, colOF).Value
lastTop(colOF - 2) = .Cells(ligneOF, colOF).Value
End If
Next colOF
shSynthese.Range("AC" & ligneRes & ":AG" & ligneRes).Interior.Color = RGB(255, 255, 255)
End If
of = of + 1
ligneRes = ligneRes + 1
End If
Set res = .Range("B:B").FindNext(After:=res)
Loop While Not res Is Nothing And res.Address <> firstAddress
'Affichage du délai et du retard
Call AfficherDelais(ligneDebut, delai)
End If
End With 'shOF
If of > 0 Then
With shSynthese.Range("R" & ligneRes - of & ":AB" & ligneRes - 1)
'bordure épaisse :
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
'couleur de cellules : blanc
.Interior.Color = RGB(255, 255, 255)
End With 'shSynthese.Range("R" & ligneRes - of & ":AB" & ligneRes - 1)
End If
shSynthese.Activate
End Function
Function CheckOFMontage(ByRef article As String, ByRef dateDebut As Date, ByRef dateFin As Date) As Integer
Dim besoin As Integer
Dim res As Range
Dim firstAddress As String
Dim ligne As Long
besoin = 0
With shOFMontage
Set res = .Range("B:B").Find(What:=article, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase _
:=False, SearchFormat:=False)
If Not res Is Nothing Then
firstAddress = res.Address
Do
ligne = res.Row
'Les ventes sont prioritaires
If .Cells(ligne, 3) >= dateDebut And .Cells(ligne, 3) < dateFin Then
besoin = besoin + .Cells(ligne, 8)
dateDebut = .Cells(ligne, 3)
End If
Set res = .Range("B:B").FindNext(After:=res)
Loop While Not res Is Nothing And res.Address <> firstAddress
End If
End With 'shOFMontage
CheckOFMontage = besoin
End Function
'Renvoie Vrai si les stocks ne sont pas suffisants pour honorer la commande
Function CheckStocks(ByRef restants() As QteStock, ByRef nbLus As Integer, ByVal article As String, ByVal besoin As Integer, ByVal stock, ByVal ladate As Date) As Long
Dim i As Integer
i = 1
While i <= nbLus And restants(i).article <> article
i = i + 1
Wend
'si on a déjà lu l'article recherché
If i <= nbLus Then
restants(i).stock = restants(i).stock - besoin
'sinon, on lit l'article pour la première fois
Else
'ajout de l'article
restants(i).stock = stock - besoin
restants(i).article = article
restants(i).dateBesoin = CDate("1 / 1 / 1900")
nbLus = nbLus + 1
End If
restants(i).stock = restants(i).stock - CheckOFMontage(article, restants(i).dateBesoin, ladate)
restants(i).dateBesoin = ladate
'les stocks suffisent-ils à satisfaire la commande en cours ?
CheckStocks = restants(i).stock
End Function
Private Sub CleanImports()
shCommande.Cells.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
shOF.Cells.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
shOA.Range("A:IV").Cells.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
shCommande.Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
shOF.Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
shOA.Range("A:IV").Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
End Sub
Private Sub MakeSynthese()
Dim restants() As QteStock 'tableau du stock restant pour chaque article lu
Dim articlesLus As Integer 'nombre d'articles lus
Dim stockTheo As Long
Dim nbOF As Integer
Dim nbOA As Integer
Dim ligneRes As Long, ligneCmd As Long
Dim col As Integer
Dim ensemble As String, projet As String, article As String
Dim lastEnsemble As String, lastProjet As String, lastArticle As String
ReDim restants(shCommande.Range("A:A").End(xlDown).Row)
With shSynthese
.Activate
With .Range("A:IV")
'Effacement des bordures sur la feuille
.Borders.LineStyle = xlLineStyleNone
'couleur de cellules : gris
.Interior.Pattern = xlPatternNone
.Interior.Color = RGB(192, 192, 192)
.ClearContents
.Font.Color = RGB(0, 0, 0)
.Font.Bold = False
End With '.Range ("A:IV")
.Range("A1:AG1") = Array("Date", "Cde", "Client", "Nom", "Lg", "Projet", "Code article", "Description", "Qté cdée", "A livrer", _
"Code article", "Description", "Besoin", "Sto phy", "Sto cde", "Sto rés", "Sto théo", "Livr", "OF", "Qté plan", " Qté réal", "Opé", " CC", "Description", "Tps all", " Temps pass", "Délai", "Retard", _
"N° ordre", "Fourn", "pos", "Qté rest", "Récept")
.Range("A1:AG1").Font.Bold = True
.Range("A1:J1").Interior.Color = RGB(0, 0, 255)
.Range("A1:J1").Font.Color = RGB(255, 255, 255)
.Range("K1:Q1").Interior.Color = RGB(255, 255, 128)
.Range("R1:AB1").Interior.Color = RGB(255, 192, 128)
.Range("AC1:AG1").Interior.Color = RGB(192, 255, 128)
Call AnnulerFusionCellules
End With
'nb de ligne ds la feuille finale
ligneRes = 2
ensemble = "aaaaaaaaaaaaaaaaa"
projet = "aaaaaaaaaaaaaaaaaaa"
article = ""
'Pour chaque commande
articlesLus = 0 'on n'a détecté aucun article
ligneCmd = 6 '1ère ligne du carnet de commandes à prendre en compte
With shSynthese
While shCommande.Cells(ligneCmd, 1) <> ""
'ligneRes = ligneRes + 1
lastEnsemble = ensemble
lastProjet = projet
lastArticle = article
ensemble = shCommande.Cells(ligneCmd, 7)
projet = shCommande.Cells(ligneCmd, 6)
article = shCommande.Cells(ligneCmd, 12)
'si la ligne correspond à un nouvel article on l'affiche
If ensemble <> lastEnsemble Or projet <> lastProjet And (projet <> "" Or lastProjet <> "") Then
'Si ni OA ni OF pour l'article précédent trouvés
If .Cells(ligneRes, 1) <> "" Then
'si la pièce est prête
If .Cells(ligneRes, 17) = "" Then
With .Range("A" & ligneRes & ":Q" & ligneRes)
If .Cells(1, 9).Value = .Cells(1, 10).Value Then
.Interior.Color = RGB(192, 255, 128) 'ligne sans OF ni OA en vert
Else
.Interior.Color = RGB(255, 255, 0) 'gestion des reliquats en jaune
shSynthese.Range("K" & ligneRes & ":Q" & ligneRes).Merge
.Cells(1, 11).Value = "En attente de décision (confirmation des reliquats)"
End If
.Font.Bold = True
End With
End If
ligneRes = ligneRes + 1 'saut de ligne pour ne pas écraser l'ensemble vide
End If
For col = 1 To 10
.Cells(ligneRes, col).Value = shCommande.Cells(ligneCmd, col).Value
Next col
'bordure épaisse :
.Range("A" & ligneRes & ":AG" & ligneRes).Borders(xlEdgeTop).Weight = xlThick
End If
If article <> "" Then
'si le stock ne suffit pas
stockTheo = CheckStocks(restants, articlesLus, article, shCommande.Cells(ligneCmd, 14).Value, shCommande.Cells(ligneCmd, 15).Value, CDate(shCommande.Cells(ligneCmd, 1).Value))
If stockTheo < 0 Then
.Cells(ligneRes, 17).Value = stockTheo
Call CopyOF(projet, article, ligneRes, nbOF)
Call CopyOA(projet, article, ligneRes, nbOA)
If article <> lastArticle Or ensemble <> lastEnsemble Then
.Cells(ligneRes, 11) = article
End If
'quantités (à livrer, stock, en commande, en réserve
For col = 13 To 17
.Cells(ligneRes, col - 1).Value = shCommande.Cells(ligneCmd, col).Value
Next col
If (nbOA > nbOF) Then nbOF = nbOA
If (nbOF > 0) Then
.Range("A" & ligneRes & ":Q" & ligneRes + nbOF - 1).Interior.Color = RGB(255, 255, 255)
ligneRes = ligneRes + nbOF
Else
With .Range("A" & ligneRes & ":Q" & ligneRes)
.Font.Color = RGB(255, 255, 255)
.Font.Bold = True
.Interior.Color = RGB(192, 0, 0)
.Interior.Pattern = xlPatternGray8
End With
ligneRes = ligneRes + 1
End If
'sinon, le stock suffit
Else
End If
End If
ligneCmd = ligneCmd + 1
Wend
If nbOF > 0 Then
' ligneRes = ligneRes - 1
End If
If ensemble = lastEnsemble And .Cells(ligneRes, 1) = "" Then
ligneRes = ligneRes - 1
Else
'éventuellement la dernière ligne est un ensemble vide, auquel cas on la colore en vert
If .Cells(ligneRes, 17) = "" Then
With .Range("A" & ligneRes & ":Q" & ligneRes)
.Interior.Color = RGB(192, 255, 128) 'ligne sans OF ni OA en vert
.Font.Bold = True
End With
End If
End If
.Range("A2:AG" & ligneRes).Borders(xlInsideVertical).Weight = xlThin
End With
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = "$A$1:$AG$" & ligneRes
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&""Arial,Gras""&14CARNET DE COMMANDES ET MANQUANTS" _
& " du " & shCommande.Range("C3").Value & " au " & shCommande.Range("C4").Value _
& Chr(10) & "Horizon des OF et OA: " & shOF.Range("C2").Value
.RightHeader = "&D"
.LeftFooter = ""
.CenterFooter = "Page &P de &N"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.354330708661417)
.TopMargin = Application.InchesToPoints(0.984251968503937)
.BottomMargin = Application.InchesToPoints(0.984251968503937)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 70
.PrintErrors = xlPrintErrorsDisplayed
End With
End Sub
Private Sub ResetForm(feuille As Worksheet)
feuille.Range("A:IV").ClearContents
End Sub
Private Sub cmdReset_Click()
If chkCC.Value = True Then Call ResetForm(shCC)
If chkCommandes.Value = True Then Call ResetForm(shCommande)
If chkOA.Value = True Then Call ResetForm(shOA)
If chkOF.Value = True Then Call ResetForm(shOF)
If chkOFMontage.Value = True Then Call ResetForm(shOFMontage)
End Sub
Private Sub cmdSyntheseDateClient_Click()
'Suppression des commentaires AG 31:0:713
Worksheets("Synthese").Columns("S:S").ClearComments
'pour eviter de ralentir, on affiche les modifs seulement à la fin
Application.ScreenUpdating = False
Call CleanImports
shCommande.Activate
Rows("6:6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("G6"), Order1:=xlAscending, _
Key2:=Range("E6"), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Selection.Sort Key1:=Range("A6"), Order1:=xlAscending, _
Key2:=Range("C6"), Order2:=xlAscending, _
Key3:=Range("B6"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Call MakeSynthese
Application.ScreenUpdating = True
End Sub
Private Sub cmdSyntheseDateCommande_Click()
'Suppression des commentaires AG 31:0:713
Worksheets("Synthese").Columns("S:S").ClearComments
'pour eviter de ralentir, on affiche les modifs seulement à la fin
Application.ScreenUpdating = False
Call CleanImports
shCommande.Activate
Rows("6:6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("A6"), Order1:=xlAscending, _
Key2:=Range("B6"), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Call MakeSynthese
Application.ScreenUpdating = True
End Sub
Private Sub MultiPage1_Change()
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = True
If Height < 50 Then
Height = 227
Else
Height = 5
End If
End Sub
Sub AnnulerFusionCellules()
Columns("A:AG").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
