[VBA] Copie de certains fichiers d'un dossier vers un autre
Effectivement c'est une erreur de ma part et j'ai corrigé la formule.
merci
Re:
j'ai un soucis avec la coloration des cases en rouge mais je ne comprend pas la formule pour être capable de la modifier. il faudrait que toutes les côtes hors tolérances càd supérieures à la côte maxi ou inférieures à la côte mini pour chaque colonne soit rouge.
j'ai ces codes là dans la mise en forme conditionnelle
=OU(XET3>XET$12;XET3<XET$13)
=OU(XFA22>XFA$12;XFA22<XFA$13)
et
=OU(XFA22>XFA$12;XFA22<XFA$13)
dans toute la plage concerné mais pour certaines cases la fonction s'exécute normalement pour d'autre il les met rouge alors qu'il ne devrait pas l'être
Bonjour
Une erreur pour trouver la dernière colonne
Modifies la partie surlignée dans le code correspondant
Application.ScreenUpdating = False
DesiCotes = Cells(10, Columns.Count).End(xlToLeft).Column
LgDer = Range("A" & Rows.Count).End(xlUp).Row
Normalement les valeurs hors tolérances sont écrites en rouge
Dans cette version tu auras les cellules en rouge
Même problème sur la V002: toutes les valeurs de la colonne Q sont fausses et pourtant seule 1l ligne sur 4 est colorée.
j'aissaie avec cette façon là mais ça ne marche pas au niveau de l'argument
For j = 1 To desicotes
Range(Cells(20, 1 + j), Cells(a, 1 + j)).Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotBetween, _
Formula1:="=Cells(12, j + 1)", Formula2:="=Cells(13, j + 1)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Bold = False
.Italic = False
.Color = -16777024
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Next
et pareil en mettant ça:
Formula1:="=$"j +1 & "$12", Formula2:="=$"j+1 & "$13"
ce code là ne bug pas mais il ne se passe rien
For j = 1 To desicotes
Range(Cells(20, 1 + j), Cells(a - 1, 1 + j)).Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotBetween, _
Formula1:="=Cells(12," & 1 + j & ")", Formula2:="=Cells(13," & 1 + j & ")"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Color = RGB(200, 0, 0)
.Bold = False
.Italic = False
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Next
La colonne S du dernier fichier n'est pas rouge or la valeur (10) n'est pas comprise entre 0 et 0.10
tu pense quoi de mon code? est ce que tu sais pourquoi ça ne marche pas?
j'abandonne pour ce soir je reprendrai demain.
Bonne soirée et merci encore pour ton aide.
Bonjour
La zone d'action de la MEFC n'était pas conforme
Corrigé dans cette version
Bonjour Banzai64,
je pense que mes explications ne sont pas claires concernant la MEFC, j'ai rajouté un 2éme exemple au fichier joint en espérant que ce soit plus compréhensible. Il faut que la colonne se décale à chaque fois exemple: pour les cellules de X20 à X26, leur valeurs doivent être comprises entre X12 et X13 et pas entre B12 et B13
Bonjour Banzai64,
voila comment j'ai contourné le probléme
For j = 1 To desicotes
For b = 20 To a - 1
If Cells(b, j + 1).Value < Cells(13, j + 1) Or Cells(b, j + 1).Value > Cells(12, j + 1) Then
Cells(b, j + 1).Font.Color = -16776961
Else
Cells(b, j + 1).Font.ColorIndex = xlAutomatic
End If
Next
Next
la limite à ce code, c'est que quand on change manuellement la valeur d'une case, elle ne change pas de couleur, ou alors il faut relancer la macro.
Bonjour
Il doit y avoir un problème
Je viens de voir le fichier que tu as posté, elle vient d'où cette MEFC ?
Surtout pas de la macro
Une fois cette règle effacée et la macro relancée j'ai une version des MEFC cohérentes
Le fichier du 2 juillet 2013 à 19h11 n'est il pas conforme ?
je le replace ici
Bonjour
Dans le fichier que tu as joint ce matin tu marques 2 fois la même règle
pour les côtes de B20 à B23: pour chacune d'elles, si la valeur est comprise entre la côte maxi (1,70) et la côte mini (1,30) alors couleur automatique noire sinon couleur rouge.
pour les côtes de K20 à K23: pour chacune d'elles, si la valeur est comprise entre la côte maxi (0,10) et la côte mini (0,00) alors couleur automatique noire sinon couleur rouge.
Dans l'image que tu as joins quelle est la règle pour
Les cellules B20:X20
Les cellules B21:X21
Les cellules B22:X22
Les cellules B23:X23
Bonjour,
Il y aurait plus tôt une règle par colonne:
de B20:B2000
C20:C2000
X20:X2000
et pour chaque colonne la condition serait "non compris entre la ligne 12 et la ligne 13 de la colonne concernée"
cdlt
Je viens de trouver la parade
je procède à une coloration du texte qui ne rempli pas les conditions avec la macro clic; puis avec une macro "private sub clic droit" dans la feuille concernée, je ré exécute cette même macro à chaque modification des cellules macro dans ma feuille concernée.
Merci pour tous ce temps passé et toutes ces solutions apportées.
El Hadj
Macro de création de rapport
Sub création_rapport()
Application.ScreenUpdating = False
Sheets(1).Visible = -1
Sheets(2).Visible = 2
Sheets(3).Visible = 2
'***********************************************DECLARATION VARIABLES***************************************
Dim Chemin As String
Dim Fichier As String
Dim nom_rapport As Variant
Dim desicotes As Variant
desicotes = ThisWorkbook.Sheets(2).Range("AA3").Value
nom_rapport = ThisWorkbook.Name
'***********************************************CREATION ET REMPLISSAGE DE L'ENTÊTE***************************************
Sheets(1).Activate
Sheets(1).Range("cmd_cli").Value = Sheets(2).Cells(8, 6)
Sheets(1).Range("cmd_int").Value = Sheets(2).Cells(9, 6)
Sheets(1).Range("qte_cont").Value = Sheets(2).Cells(13, 6)
Sheets(1).Range("qte_livre").Value = Sheets(2).Cells(14, 6)
Sheets(1).Range("of").Value = Sheets(2).Cells(12, 6)
Sheets(1).Range("lot_mat").Value = Sheets(2).Cells(15, 6)
Sheets(1).Range("lot_grav").Value = Sheets(2).Cells(16, 6)
Sheets(1).Range("date_rapport").Value = Sheets(2).Cells(17, 6)
Sheets(1).Range("visa").Value = Sheets(2).Cells(18, 6)
Sheets(1).Range("freq").Value = Sheets(2).Cells(19, 6)
'***CONDITIONS SUR LES INSERTS TANTALES*************************************************
If Sheets(3).Range("$AC$3") = True Then
If Sheets(2).Range("H23").Value <> "" Then
Sheets(1).Range("lot_tant_1").Value = Sheets(2).Cells(23, 6)
Else
Sheets(1).Range("lot_tant_1").Value = ClearContents
End If
'*****************************************************
If Sheets(2).Range("H24").Value <> "" Then
Sheets(1).Range("lot_tant_2").Value = Sheets(2).Cells(24, 6)
Else
Sheets(1).Range("lot_tant_2").Value = ClearContents
End If
'******************************************************
If Sheets(2).Range("H25").Value <> "" Then
Sheets(1).Range("lot_tant_3").Value = Sheets(2).Cells(25, 6)
Else
Sheets(1).Range("lot_tant_3").Value = ClearContents
End If
'*******************************************************
Else
Sheets(1).Range("lot_tant_1").Value = ClearContents
Sheets(1).Range("lot_tant_2").Value = ClearContents
Sheets(1).Range("lot_tant_3").Value = ClearContents
End If
'***CONDITIONS SUR LES INSERTS TITANES*************************************************
If Sheets(3).Range("$AC$4") = True Then
If Sheets(2).Range("H26").Value <> "" Then
Sheets(1).Range("lot_tant_1").Value = Sheets(2).Cells(26, 6)
Else
Sheets(1).Range("lot_tant_1").Value = ClearContents
End If
'*****************************************************
If Sheets(2).Range("H27").Value <> "" Then
Sheets(1).Range("lot_tant_2").Value = Sheets(2).Cells(27, 6)
Else
Sheets(1).Range("lot_tant_2").Value = ClearContents
End If
'******************************************************
If Sheets(2).Range("H28").Value <> "" Then
Sheets(1).Range("lot_tant_3").Value = Sheets(2).Cells(28, 6)
Else
Sheets(1).Range("lot_tant_3").Value = ClearContents
End If
'*******************************************************
End If
'***********************************************OUVERTURE DES FICHIERS ET COPIE DES VALEURS*****************************************************************
Chemin = "W:\tridim\Rapport\Client\" & Sheets(1).Range("client") & "\" & Sheets(1).Range("cmd_int") & "\" & Sheets(1).Range("code_produit") & "\N°OF" & Sheets(1).Range("of") & "\"
Fichier = Dir(Chemin & "*.xls")
a = 20
Do While Fichier <> "" 'Boucle tant que l'on trouve un NOUVEAU fichier
If Val(Fichier) > 0 And IsNumeric(Left(Fichier, Len(Fichier) - 4)) Then
With Workbooks.Open(Chemin & Fichier)
For j = 1 To desicotes
If Sheets(1).Cells(7 + 2 * j, 3).Value = "Rectitude" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Circularité" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Coaxialité" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Parallélisme" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Perpendicularité" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Tol. symétrie sur élément pt" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Tol. symétrie sur élément axe" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Tol. symétrie sur élément plan" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Battement radial" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Inclinaison" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Concentricité" Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
ElseIf Sheets(1).Cells(7 + 2 * j, 3).Value = "Loca." Then
Sheets(1).Cells(6 + 2 * j, 8).Copy
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
Else
Sheets(1).Cells(6 + 2 * j, 7).Copy 'COPIES VALEURS
Windows(nom_rapport).Activate
Sheets(1).Range("A" & a).Value = (Left(Fichier, Len(Fichier) - 4))
Sheets(1).Cells(a, 1 + j).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Windows(Fichier).Activate
End If
Next
.Close
End With
a = a + 1
End If
Fichier = Dir ' Va voir s'il existe un autre fichier
Loop
'***********************************************MISE EN FORME CONDITIONNELLE*****************************************************************
Windows(nom_rapport).Activate
a = a - 1
Range("A1") = a
Range(Range("A20"), Cells(a, desicotes + 1)).Sort Key1:=Range("A20"), Order1:=xlAscending, Header:=xlNo
Sheets(1).Range(Range("A20"), Cells(a, desicotes + 1)).Select
With Selection
.Font.Name = "Arial"
.Font.Size = 8
.Font.Strikethrough = False
.Font.Superscript = False
.Font.Subscript = False
.Font.OutlineFont = False
.Font.Shadow = False
.Font.Underline = xlUnderlineStyleNone
.Font.ThemeColor = xlThemeColorLight1
.Font.TintAndShade = 0
.Font.ThemeFont = xlThemeFontNone
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Sheets(1).Range(Range("B15"), Cells(a, desicotes + 1)).NumberFormat = "0.00"
Range(Range("B15"), Cells(15, desicotes + 1)).Formula = "=AVERAGE(R20C:R" & a & "C)"
Range(Range("B16"), Cells(16, desicotes + 1)).Formula = "=STDEV(R20C:R" & a & "C)"
Range(Range("B17"), Cells(17, desicotes + 1)).Formula = "=MAX(R20C:R" & a & "C)"
Range(Range("B18"), Cells(18, desicotes + 1)).Formula = "=MIN(R20C:R" & a & "C)"
Range(Range("B19"), Cells(19, desicotes + 1)).Formula = "=R[-2]C-R[-1]C"
For j = 1 To desicotes
For b = 20 To a
If Cells(b, j + 1).Value < Cells(13, j + 1) Or Cells(b, j + 1).Value > Cells(12, j + 1) Then
Cells(b, j + 1).Font.Color = -16776961
Else
Cells(b, j + 1).Font.ColorIndex = xlAutomatic
End If
Next
Next
'***********************************************ENREGISTREMENT DU RAPPORT*****************************************************************
ActiveWorkbook.SaveAs Filename:="W:\tridim\Rapport\Client\" & Sheets(1).Range("client") & "\" & Sheets(1).Range("cmd_int") & "\" & Sheets(1).Range("code_produit") & "\N°OF" & Sheets(1).Range("of") & "\Rapport de l'OF" & Sheets(1).Range("of") & ".xlsm"
End Sub
Macro dans la page pour la mise à jour de la formule qui remplace la MEFC
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
a = Sheets(1).Range("A1").Value
desicotes = Sheets(2).Range("AA3")
For j = 1 To desicotes
For b = 20 To a
If Cells(b, j + 1).Value < Cells(13, j + 1) Or Cells(b, j + 1).Value > Cells(12, j + 1) Then
Cells(b, j + 1).Font.Color = -16776961
Else
Cells(b, j + 1).Font.ColorIndex = xlAutomatic
End If
Next
Next
End Sub
Bonjour Banzai64
aurais tu un peu de temps pour jeter un œil à mon problème actuel?
Mon chef m'a rajouté une nouvelle difficulté, faire la MEFC en fonction du nombre de chiffre après la virgule. pour cela j'ai besoin de compter le nombre de décimales de certaines cellules, ce que j'arrive à faire mais les résultats que j'obtiens sont aléatoirement bizarre.
je te joint le fichier exemple.
cordialement,
Bonjour
Comme tu as une réponse ici https://forum.excel-pratique.com/excel/compter-le-nbre-de-chiffres-apres-la-virgule-macro-t41375-10.html
Pas la peine de s'occuper de ce sujet
bonjour banzai64
désolé j'ai oublié d'éditer mon message pour te dire que c'est bon eriiic m'as donné la solution
je suis entrain de l'adapter à mon fichier.
bonne journée et merci
Elhadj