[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

Bonjour

Je ne comprends pas

Voila le résultat que j'obtiens

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, je t'ai fait une capture d'écran de ce que j'ai actuellement et une de ce que je voudrai avoir.

il y a une erreur dans l'exposé de mon point 4 d'où le fichier MEFC que j'ai posté ce matin

cdlt

capture1 capture2

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

Bonjour

Message rectifié

J'ai chargé le fichier que j'avais posté "Elhadj Recopie V004.xlsm" et voici le résultat que j'obtiens

mefc elhadj

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

Rechercher des sujets similaires à "vba copie certains fichiers dossier"