Détecter des écarts de température

degap05 · 14 Janvier 2010

Bonjour,

Je viens chercher de l'aide auprès de vous.
Dans le fichier joint, une macro (enregistreur de macro), me permet de récupérer les données d'un fichier texte, en feuille "Données".
Il s'agit d'un relevé de température pour 2 soudeuses (T1 et T2).
La température limite inférieure est de 175°.
La température limite supérieure est de 185°.
J'aimerais mettre les anomalies en évidence et en créer un récapitulatif, en feuille "Récapitulatif". Les données venant s'ajouter à la suite.
Pour distinguer les données erronées, j'ai pensé colorer la cellule concernée, reporter l'écart en colonne "D", précédé de T1 ou T2.
Ceci se faisant à l'activation de la macro d'importation des données du fichier texte.
Merci de votre aide.

jp14 · 14 Janvier 2010

Re : Détecter des écarts de température

Bonsoir

Ci dessous un code à tester

Code:

Sub travdem()
Dim cellule As Range
Dim nomfeuille1 As String, nomfeuille2 As String
Dim valmax As Currency, valmin As Currency
Dim def As Boolean
' pour boucler sur la colonne 1
valmax = 185
valmin = 175
'La température limite inférieure est de 175°.
'La température limite supérieure est de 185°

nomfeuille1 = "Données"
nomfeuille2 = "Récapitulatif"
Sheets(nomfeuille2).UsedRange.Offset(1).Clear

With Sheets(nomfeuille1)
For Each cellule In .Range("b2:b" & .Cells(Columns(2).Cells.Count, 1).End(xlUp).Row)

    If cellule.Value < valmin Or cellule.Value > valmax Then def = True
    If def = False Then
    If cellule.Offset(0, 1).Value < valmin Or cellule.Offset(0, 1).Value > valmax Then def = True
    End If
    If def = True Then
    .Rows(cellule.Row).Copy _
     Destination:=Sheets(nomfeuille2).Rows(Sheets(nomfeuille2).Range("a65536").End(xlUp).Row + 1)
    def = False
    End If
Next cellule
End With
End Sub

JP

job75 · 14 Janvier 2010

Re : Détecter des écarts de température

Bonsoir degap05, JP,

Ci joint le fichier avec cette macro :

Code:

Option Base 1

Sub Ecarts()
Dim tablo, tablo1$(), tablo2$(), i&, j As Byte, v As Double, n&
tablo = Sheets("Données").Range("A2:C" & Sheets("Données").Range("A65536").End(xlUp).Row)
ReDim tablo1(UBound(tablo))
'---remplissage de tablo1 et tablo2---
For i = 1 To UBound(tablo)
  For j = 2 To 3
    v = Val(Replace(tablo(i, j), ",", "."))
    If v And (v < 175 Or v > 185) Then
      n = n + 1
      tablo1(i) = "T" & j - 1 & IIf(v < 175, " - " & 175 - v, " + " & v - 185)
      ReDim Preserve tablo2(4, n)
      tablo2(1, n) = Trim(tablo(i, 1))
      tablo2(2, n) = tablo(i, 2)
      tablo2(3, n) = tablo(i, 3)
      tablo2(4, n) = tablo1(i)
    End If
  Next
Next
'---transfert vers les feuilles---
With Sheets("Données").Range("D2:D65536")
  .ClearContents
  .Resize(UBound(tablo)) = Application.Transpose(tablo1)
End With
With Sheets("Récapitulatif").Range("A2:D65536")
  .ClearContents
  .Resize(n) = Application.Transpose(tablo2)
  .Replace ",", ".", LookAt:=xlPart 'convertit en valeurs numériques (colonnes B et C)
End With
End Sub

La macro crée 3 tableaux, ce qui permet de gagner beaucoup de temps de calcul, on s'en aperçoit s'il y a un grand nombre de valeurs.

Dans la feuille Données, toutes les valeurs sont des textes, ce qui est classique sur des données importées.

Je n'ai pas cherché à les convertir, mais j'ai cependant convertit les valeurs obtenues en colonnes B et C de la feuille Récapitulatif.

Edit : les colonnes B et C de Données ont une Mise en forme conditionnelle (MFC) avec la formule :

=B1*OU(CNUM(B1)<175;CNUM(B1)>185)

A+

degap05 · 15 Janvier 2010

Re : Détecter des écarts de température

Bonjour job75, jp14, paritec et le forum,

Merci de vos propositions.
Pour l'instant, j'ai examiné de prés le fichier de job75, qui fonctionne très bien.
Pour aller plus loin dans ma démarche, j'aimerais traiter les données mensuellement (onglets "Janvier", "Février", etc...). J'ai donc adapté la macro. Cela fonctionne partiellement car je bute sur la partie:

With Sheets("Récapitulatif").Range("A2😀65536")
.ClearContents
.Resize(n) = Application.Transpose(tablo2)
.Replace ",", ".", LookAt:=xlPart 'convertit en valeurs numériques (colonnes B et C)
End With

afin que les données se cumulent en feuille "Récapitulatif".

La mise en forme conditionnelle est parfaite.

Serait-il possible de convertir, dès le départ, les données importées en données numériques ?
Merci.

degap05 · 15 Janvier 2010

Re : Détecter des écarts de température

jp14 à dit:

Bonsoir

Ci dessous un code à tester

Code:

Sub travdem()
Dim cellule As Range
Dim nomfeuille1 As String, nomfeuille2 As String
Dim valmax As Currency, valmin As Currency
Dim def As Boolean
' pour boucler sur la colonne 1
valmax = 185
valmin = 175
'La température limite inférieure est de 175°.
'La température limite supérieure est de 185°

nomfeuille1 = "Données"
nomfeuille2 = "Récapitulatif"
Sheets(nomfeuille2).UsedRange.Offset(1).Clear

With Sheets(nomfeuille1)
For Each cellule In .Range("b2:b" & .Cells(Columns(2).Cells.Count, 1).End(xlUp).Row)

    If cellule.Value < valmin Or cellule.Value > valmax Then def = True
    If def = False Then
    If cellule.Offset(0, 1).Value < valmin Or cellule.Offset(0, 1).Value > valmax Then def = True
    End If
    If def = True Then
    .Rows(cellule.Row).Copy _
     Destination:=Sheets(nomfeuille2).Rows(Sheets(nomfeuille2).Range("a65536").End(xlUp).Row + 1)
    def = False
    End If
Next cellule
End With
End Sub

JP

Bonjour jp14,
Je viens de tester ta macro, qui fonctionne très bien.
J'ai juste modifié: With Sheets(nomfeuille1), en With ActiveSheet.
Je formulerais la même demande que dans mon message précédent, pour traiter les données mensuellement et que les anomalies se cumulent dans la feuille "Récapitulatif".
Merci.
A+

job75 · 15 Janvier 2010

Re : Détecter des écarts de température

Bonjour degap05, le fil,

La macro adaptée pour traiter toutes les feuilles sauf "Récapitulatif" :

Code:

Option Base 1

Sub Ecarts()
Dim F As Worksheet, tablo, tablo1$(), tablo2$(), i&, j As Byte, v As Double, n&
[COLOR="Red"]Sheets("Récapitulatif").Range("A2:D65536").ClearContents[/COLOR]
For Each F In Worksheets
  If F.Name <> "Récapitulatif" Then
    tablo = F.Range("A2:C" & F.Range("A65536").End(xlUp).Row)
    ReDim tablo1(UBound(tablo))
    n = 0
    '---remplissage des tablo1 et tablo2---
    For i = 1 To UBound(tablo)
      For j = 2 To 3
        v = Val(Replace(tablo(i, j), ",", "."))
        If v And (v < 175 Or v > 185) Then
          n = n + 1
          tablo1(i) = "T" & j - 1 & IIf(v < 175, " - " & 175 - v, " + " & v - 185)
          ReDim Preserve tablo2(4, n)
          tablo2(1, n) = Trim(tablo(i, 1))
          tablo2(2, n) = tablo(i, 2)
          tablo2(3, n) = tablo(i, 3)
          tablo2(4, n) = tablo1(i)
        End If
      Next
    Next
    '---transfert vers les feuilles---
    With F.Range("D2:D65536")
      .ClearContents
      .Resize(UBound(tablo)) = Application.Transpose(tablo1)
    End With
    With [COLOR="red"]Sheets("Récapitulatif").Range("A65536").End(xlUp)(2).Resize(n, 4)[/COLOR]
      [COLOR="Red"].Offset(, 4).Resize(1, 1) = F.Name 'indique la feuille en colonne E[/COLOR]
      .Value = Application.Transpose(tablo2)
      .Replace ",", ".", LookAt:=xlPart 'convertit en valeurs numériques (colonnes B et C)
    End With
  End If
Next
End Sub

Un seul bouton dans la feuille "Récapitulatif" suffit.

Edit : salut JP, comme toi j'ai modifié pour indiquer la feuille (mois).

A+

jp14 · 15 Janvier 2010

Re : Détecter des écarts de température

Bonjour

Ci dessous la procédure modifiée.

Code:

Sub travdem()
Dim cellule As Range
Dim nomfeuille1 As String, nomfeuille2 As String
Dim valmax As Currency, valmin As Currency
Dim def As Boolean
' pour boucler sur la colonne 1
valmax = 185
valmin = 175
'La température limite inférieure est de 175°.
'La température limite supérieure est de 185°

nomfeuille1 = ActiveSheet.Name
nomfeuille2 = "Récapitulatif"
'Sheets(nomfeuille2).UsedRange.Offset(1).Clear
With Sheets(nomfeuille2)
.Range("a" & .Range("a65536").End(xlUp).Row + 1) = nomfeuille1
End With
With Sheets(nomfeuille1)
For Each cellule In .Range("b2:b" & .Cells(Columns(2).Cells.Count, 1).End(xlUp).Row)
    If IsNumeric(cellule) Then
    If cellule.Value < valmin Or cellule.Value > valmax Then
        def = True
        cellule.Offset(0, 2) = "T1 " & IIf(CCur(cellule.Value) < 175, " - " & 175 - CCur(cellule.Value), " + " & CCur(cellule.Value) - 185)

    End If
    
    If def = False Then
    If cellule.Offset(0, 1).Value < valmin Or cellule.Offset(0, 1).Value > valmax Then
        def = True
        cellule.Offset(0, 2) = "T2 " & IIf(CCur(cellule.Offset(0, 1).Value) < 175, " - " & 175 - CCur(cellule.Offset(0, 1).Value), " + " & CCur(cellule.Offset(0, 1).Value) - 185)
    End If
    End If
    If def = True Then
    .Rows(cellule.Row).Copy _
     Destination:=Sheets(nomfeuille2).Rows(Sheets(nomfeuille2).Range("a65536").End(xlUp).Row + 1)
    def = False
    End If
    End If
Next cellule
End With
With Sheets(nomfeuille2)
.Range("a" & .Range("a65536").End(xlUp).Row + 1) = " "
End With
End Sub

J'ai rajouté des lignes pour mieux visualiser les mois.
JP

degap05 · 15 Janvier 2010

Re : Détecter des écarts de température

Bonjour jp14,

Cela fonctionne parfaitement.
L'ajout d'une ligne avec le nom du mois, dans le récapitulatif, est parfait.
Le dernier perfectionnement à apporter, serait de n'afficher que les données erronées dans le récapitulatif. Mais je comprends qu'il est plus facile de copier la ligne complète ou se trouve un chiffre incorrect.
Mais je suis tellement admiratif de ce que peuvent faire les "sorciers" du forum que je me dis que rien ne leur est impossible !!

Merci.

job75 · 15 Janvier 2010

Re : Détecter des écarts de température

Re,

degap05 à dit:
Le dernier perfectionnement à apporter, serait de n'afficher que les données erronées dans le récapitulatif.

Voir la ligne en rouge :

Code:

Option Base 1

Sub Ecarts()
Dim F As Worksheet, tablo, tablo1$(), tablo2$(), i&, j As Byte, v As Double, n&
Sheets("Récapitulatif").Range("A2:D65536").ClearContents
For Each F In Worksheets
  If F.Name <> "Récapitulatif" Then
    tablo = F.Range("A2:C" & F.Range("A65536").End(xlUp).Row)
    ReDim tablo1(UBound(tablo))
    n = 0
    '---remplissage des tablo1 et tablo2---
    For i = 1 To UBound(tablo)
      For j = 2 To 3
        v = Val(Replace(tablo(i, j), ",", "."))
        If v And (v < 175 Or v > 185) Then
          n = n + 1
          tablo1(i) = "T" & j - 1 & IIf(v < 175, " - " & 175 - v, " + " & v - 185)
          ReDim Preserve tablo2(4, n)
          tablo2(1, n) = Trim(tablo(i, 1))
         [COLOR="Red"] If v < 175 Then tablo2(2, n) = tablo(i, 2) Else tablo2(3, n) = tablo(i, 3)[/COLOR]
          tablo2(4, n) = tablo1(i)
        End If
      Next
    Next
    '---transfert vers les feuilles---
    With F.Range("D2:D65536")
      .ClearContents
      .Resize(UBound(tablo)) = Application.Transpose(tablo1)
    End With
    With Sheets("Récapitulatif").Range("A65536").End(xlUp)(2).Resize(n, 4)
      .Offset(, 4).Resize(1, 1) = F.Name 'indique la feuille en colonne E
      .Value = Application.Transpose(tablo2)
      .Replace ",", ".", LookAt:=xlPart 'convertit en valeurs numériques (colonnes B et C)
    End With
  End If
Next
End Sub

A+

degap05 · 15 Janvier 2010

Re : Détecter des écarts de température

Job 75, ta réponse arrive avant que je n'ai eu le temps de formuler mon message !!!

Toutes les données ne sont pas justes. Par exemple à la 2ème ligne, l'anomalie est en T1 et c'est T2 qui s'affiche.

Juste une inversion, je suppose.

A+

job75 · 15 Janvier 2010

Re : Détecter des écarts de température

Re,

Où avais-je la tête ?

Code:

Option Base 1

Sub Ecarts()
Dim F As Worksheet, tablo, tablo1$(), tablo2$(), i&, j As Byte, v As Double, n&
Sheets("Récapitulatif").Range("[COLOR="Red"]A2:E65536[/COLOR]").ClearContents
For Each F In Worksheets
  If F.Name <> "Récapitulatif" Then
    tablo = F.Range("A2:C" & F.Range("A65536").End(xlUp).Row)
    ReDim tablo1(UBound(tablo))
    n = 0
    '---remplissage des tablo1 et tablo2---
    For i = 1 To UBound(tablo)
      For j = 2 To 3
        v = Val(Replace(tablo(i, j), ",", "."))
        If v And (v < 175 Or v > 185) Then
          n = n + 1
          tablo1(i) = "T" & j - 1 & IIf(v < 175, " - " & 175 - v, " + " & v - 185)
          ReDim Preserve tablo2(4, n)
          tablo2(1, n) = Trim(tablo(i, 1))
          [COLOR="Red"]If j = 2 Then tablo2(2, n) = tablo(i, 2)
          If j = 3 Then tablo2(3, n) = tablo(i, 3)[/COLOR]
          tablo2(4, n) = tablo1(i)
        End If
      Next
    Next
    '---transfert vers les feuilles---
    With F.Range("D2:D65536")
      .ClearContents
      .Resize(UBound(tablo)) = Application.Transpose(tablo1)
    End With
    With Sheets("Récapitulatif").Range("A65536").End(xlUp)(2).Resize(n, 4)
      .Offset(, 4).Resize(1, 1) = F.Name 'indique la feuille en colonne E
      .Value = Application.Transpose(tablo2)
      .Replace ",", ".", LookAt:=xlPart 'convertit en valeurs numériques (colonnes B et C)
    End With
  End If
Next
End Sub

Edit : j'avais oublié aussi de vider au début la colonne E...

A+

degap05 · 15 Janvier 2010

Re : Détecter des écarts de température

Bonsoir Job75,

Merci pour tout ce travail.
Moi je n'ai pas fait grand-chose....., à part admirer !!
Le fonctionnement est parfait.
Encore merci, ainsi qu'à Jp14.

Bon weekend.

job75 · 16 Janvier 2010

Re : Détecter des écarts de température

Bonsoir degap05,

Il y avait encore un problème avec la dernière modification.

Le ReDim Preserve... Eh bien il préserve les valeurs pour n = 1 (1ère anomalie du mois suivant). Donc, il faut modifier les 2 valeurs T1 et T2 :

Code:

Option Base 1

Sub Ecarts()
Dim F As Worksheet, tablo, tablo1$(), tablo2$(), i&, j As Byte, v As Double, n&
Sheets("Récapitulatif").Range("A2:E65536").ClearContents
For Each F In Worksheets
  If F.Name <> "Récapitulatif" Then
    tablo = F.Range("A2:C" & F.Range("A65536").End(xlUp).Row)
    ReDim tablo1(UBound(tablo))
    n = 0
    '---remplissage des tablo1 et tablo2---
    For i = 1 To UBound(tablo)
      For j = 2 To 3
        v = Val(Replace(tablo(i, j), ",", "."))
        If v And (v < 175 Or v > 185) Then
          n = n + 1
          tablo1(i) = "T" & j - 1 & IIf(v < 175, " - " & 175 - v, " + " & v - 185)
          ReDim Preserve tablo2(4, n)
          tablo2(1, n) = Trim(tablo(i, 1))
          [COLOR="Red"]tablo2(2, n) = IIf(j = 2, tablo(i, 2), "")
          tablo2(3, n) = IIf(j = 3, tablo(i, 3), "")[/COLOR]
          tablo2(4, n) = tablo1(i)
        End If
      Next
    Next
    '---transfert vers les feuilles---
    With F.Range("D2:D65536")
      .ClearContents
      .Resize(UBound(tablo)) = Application.Transpose(tablo1)
    End With
    With Sheets("Récapitulatif").Range("A65536").End(xlUp)(2).Resize(n, 4)
      .Offset(, 4).Resize(1, 1) = F.Name 'indique la feuille en colonne E
      .Value = Application.Transpose(tablo2)
      .Replace ",", ".", LookAt:=xlPart 'convertit en valeurs numériques (colonnes B et C)
    End With
  End If
Next
End Sub

Bonne nuit.

degap05 · 16 Janvier 2010

Re : Détecter des écarts de température

Bonjour Job75,

Merci pour le MP.
Je vois la modification que tu as effectuée, mais je ne vois pas la différence sur le résultat obtenu 😱

Quelle était l'erreur engendrée ?
C'est juste pour essayer de comprendre ton travail.

Merci.
A+

job75 · 16 Janvier 2010

Re : Détecter des écarts de température

Bonjour degap05,

degap05 à dit:
Quelle était l'erreur engendrée ?
C'est juste pour essayer de comprendre ton travail.

Sur chaque fichier Soudeuse(4) et Soudeuse(5), en feuille Février, au niveau de la 1ère anomalie, intervertissez les valeurs T1 et T2 et voyez le résultat...

A+

Détecter des écarts de température

degap05

XLDnaute Impliqué

Pièces jointes

jp14

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

degap05

XLDnaute Impliqué

Pièces jointes

degap05

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Pièces jointes

jp14

XLDnaute Barbatruc

degap05

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Pièces jointes

degap05

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Pièces jointes

degap05

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Pièces jointes

degap05

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Discussions similaires

Détecter des écarts de température

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency