XL 2010 VBA copie données d'une Feuil à l'autre + MFC

spike29 · 9 Décembre 2020

Bonjour,

J'ai un classeur dans lequel se trouve une feuil de suivi et une seconde Feuil de planning.

Débutant en VBA je souhaiterai récupérer des informations de la Feuil"Planning" afin de les insérer dans la Feuil_suivi notamment dans la colonne "Zone 2" de cette dernière.

Besoin n° 1 :

En fonction de la date du jour présente en Feuil_suivi cellule E18 la macro va venir chercher les informations dans la colonne adéquate de la Feuil_Planning a savoir systématiquement sélectionner la colonne JOUR de la date du jour.
Exemple pour ce Mercredi 09.12.2020 => Colonne G

- La macro va ensuite copier les chiffres présents en G3 et G5 respectivement en cellule D12 & E12 dans la Feuil_suivi

Besoins n° 2 :

Dans les différentes colonnes JOUR Feuil_planning se trouve des n° items (X1 etc...) accompagnés de textes variés. Ces n° d'items sont positionnés dans des cellules spécifiques qui correspondent aux différentes zones ( pour être raccord avec les zones reprises dans la colonne E de mon tableau Feuil_suivi il ne faudra retenir que les chiffres et non les lettres, exemple pour "A8" retenir "8")

Objectif :

Dans la colonne F de ma Feuil_suivi, venir automatiquement renseigner les n° de zones dans lesquelles sont placés les items (X1 etc...) dans la Feuil_Planning.
Uniquement prendre en compte les chiffes pour les zones et non la lettre => Ex 8 et non A8.

Autre besoin => Mise en forme conditionnelle :

Condition 1 : Feuil_suivi => colonne D (opérations) si les cellules contiennent :
LA ou MC , ne contiennent pas "CONFIG"et que cellules col F <> "" et que cellule colonne L (status) <> "valider" alors colorier en orange la cellule colonne D

Conditions 2 Feuil_suivi => colonne D (opérations) si les cellules contiennent :
LA ou MC, ne contiennent pas "CONFIG" et que cellules col F = "" et que cellule colonne L (status) <> "valider" alors colorier en bleu la cellule colonne D

En PJ vous trouverez mon fichier avec le résultat attendu dans la Feuil résultat attendu.

Un début de code que j'ai trouvé ci-dessous.

VB:

With Sheets("Feuil_suivi")
 
  Worksheets("Feuil_suivi").Activate
 
 
    compteur = 0
    
  For cellule = 26 To Range("D" & Rows.Count).End(xlUp).Row

      If UCase(Cells(cellule, 4).Value) & " " Like "*LA*" Or UCase(Cells(cellule, 4).Value) & " " Like "*MC*"  Then
      
  
        Cells(cellule, 4).Interior.ColorIndex = 41
        compteur = compteur + 1
      Else
        Cells(cellule, 4).Interior.ColorIndex = xlNone
      End If
  Next cellule

 
 
  End With

Merci d'avance pour vos réponses et bonne fin de journée.

Rouge · 11 Décembre 2020

Bonjour,

Pour la question 1, pas de problème une simple formule suffit, par contre pour la 2ème question, je ne comprends pas , on doit récupérer uniquement le N° de la zone (donc colonne A de "planning") si dans les colonnes Jour ou Nuit il y a une info du genre X1, X9 etc.. mais le problème est que cette colonne A il y a des zones sans N° par exemple "TP", que faut-il faire dans ces cas là.
De plus je suppose que ces infos viennent s'ajouter au jour le jour dans la "Feuil_suivi" et que celles du jour ne viennent pas écraser celles des jours précédents.

Si vous pouviez être un peu plus précis concernant la question 2, voire même donner des exemples pour être sûr d'avoir bien compris.

Cdlt

spike29 · 11 Décembre 2020

Bonjour Rouge et merci de votre retour,

On vient chercher le n° de zone uniquement pour les colonnes "JOUR" de la date du jour (la macro ne traitera pas les colonnes nuit)

Exemple pour aujourd'hui, prendre en compte la colonne K (Vendredi 11 Décembre JOUR).

Pour le reste vous avez visiblement bien compris mon besoin, il s'agit de récupérer les n° de zones de la colonne A de la Feuil Planning dès lors qu'il y a une valeur (X1,X9 etc...) dans la colonne JOUR de la date du jour (col K pour aujourd'hui).

Effectivement, j'aurais du préciser le cas des zones sans n° (TP notamment). Ces zones là il faut les copier telles quelles.

Les informations d'une journée à l'autre ne viennent pas s'ajouter au jour le jour dans la Feuil_suivi.
Chaque journée est traitée de manière indépendante, le reste de ma macro viendra de toute manière écraser les données de la veille dans la Feuil_suivi.
Pas de problématique à ce niveau là, il faut donc raisonner uniquement sur la journée en cours.

En cas de doute j'ai mis le résultat attendu dans la Feuil résultat attendu de mon fichier.

En espérant avoir vous avoir apporté les éléments nécessaires pour éclaircir mon besoin.

N'hésitez surtout pas s'il reste des zones d'ombres. Et merci pour votre aide.

Bonne journée

Cdt,

jpb388 · 11 Décembre 2020

Bonjour à tous
réponse 1
en d12 =

Code:

=INDEX(planning!3:3;1;EQUIV(E18;planning!1:1;0))

e12 =

Code:

=INDEX(planning!5:5;1;EQUIV(E18;planning!1:1;0))

réponse 2
déclarer la référence Scripting runtime

VB:

Sub Macro1()
      Dim Dico As New Dictionary, Cel As Range, Pl As Range, Suiv As Worksheet, Plan As Worksheet, strAd, Col&, Ref$, MaCel$
      Set Suiv = Feuil1
      Set Plan = Feuil3
      Set Pl = Suiv.Range("B26:U" & Suiv.Range("B" & Rows.Count).End(xlUp).Row)
      Col = WorksheetFunction.Match(Suiv.Range("E18"), Plan.Rows("1:1"), 0) + 1
      For Each strAd In Split(Plan.Range(Plan.Cells(12, Col), Plan.Cells(Rows.Count, Col)).SpecialCells(xlCellTypeConstants).Address, ",")
            MaCel = StrConv(Plan.Range(strAd).Text, vbUpperCase)
            If Not Dico.Exists(MaCel) Then Dico.Add MaCel, TrouveChiffre(Plan.Range("A" & Plan.Range(strAd).Row))
      Next strAd
            MaCel = ""
      For Each Cel In Pl.Rows
            MaCel = StrConv(Cel.Cells(1).Text, vbUpperCase)
            If Dico.Exists(MaCel) Then Cel.Cells(1).Offset(0, 4) = Dico.Item(MaCel)
      Next Cel
End Sub

Function TrouveChiffre(vCh$) As Integer
      Dim Ch&, X As Byte
      For X = 1 To Len(vCh)
            If IsNumeric(Mid(vCh, X, 1)) Then Ch = Ch & Mid(vCh, X, 1)
      Next
      TrouveChiffre = CInt(Ch)
End Function

spike29 · 11 Décembre 2020

Bonjour JP et merci pour ta réponse,

Je viens de coller la réponse 2 dans un module standard après avoir bien activé Scripting runtime mais ça me remonte une erreur 1004 " pas de cellules correspondantes" à la ligne suivante :

VB:

 For Each strAd In Split(Plan.Range(Plan.Cells(12, Col), Plan.Cells(Rows.Count, Col)).SpecialCells(xlCellTypeConstants).Address, ",")

J'ai beau creuser je ne vois pas du tout d'où cela peut venir.
Dans le doute j'ai tenté de déclencher cette macro depuis la Feuil de calcul mais même problème.

Bonne journée

Cdt,

jpb388 · 11 Décembre 2020

as tu mis des X1 et autres dans la colonne correspondante au jour
je n'ai pas mis de garde fou pensant que sur ton original il y aurai au moins une occurrence
chez moi c'est ok

jpb388 · 12 Décembre 2020

Bonjour à tous
J'ai oublié la couleur

VB:

Sub Macro1()
      Dim Dico As New Dictionary, Cel As Range, Pl As Range, Suiv As Worksheet, Plan As Worksheet
      Dim lgSuiv&, strAd, Col&, Ref$, MaCel$
      Set Suiv = Feuil1
      Set Plan = Feuil3
      lgSuiv = Suiv.Range("B" & Rows.Count).End(xlUp).Row
      Suiv.Range("F26:F" & lgSuiv).ClearContents
      Suiv.Range("D26:D" & lgSuiv).Interior.Color = xlNone
      Set Pl = Suiv.Range("B26:U" & lgSuiv)
      Col = WorksheetFunction.Match(Suiv.Range("E18"), Plan.Rows("1:1"), 0) + 1
      On Error Resume Next
      For Each strAd In Split(Plan.Range(Plan.Cells(12, Col), Plan.Cells(Rows.Count, Col)).SpecialCells(xlCellTypeConstants).Address, ",")
      If Err.Number > 0 Then GoTo Erreurs
            MaCel = StrConv(Plan.Range(strAd).Text, vbUpperCase)
            If Not Dico.Exists(MaCel) Then Dico.Add MaCel, TrouveChiffre(Plan.Range("A" & Plan.Range(strAd).Row))
      Next strAd
            MaCel = ""
      For Each Cel In Pl.Rows
            MaCel = StrConv(Cel.Cells(1).Text, vbUpperCase)
            If Dico.Exists(MaCel) Then Cel.Cells(1).Offset(0, 4) = Dico.Item(MaCel)
            Coloriage Cel.Row
      Next Cel
      Exit Sub
Erreurs:
      Select Case Err.Number
            Case 1004: MsgBox "Aucune occurence trouvée", vbOKOnly + vbInformation, "Données Manquantes"
            
      End Select
End Sub

Private Function TrouveChiffre(vCh$) As Integer
      Dim Ch&, X As Byte
      For X = 1 To Len(vCh)
            If IsNumeric(Mid(vCh, X, 1)) Then Ch = Ch & Mid(vCh, X, 1)
      Next
      TrouveChiffre = CInt(Ch)
End Function

Private Sub Coloriage(Lg&)
      Select Case Left(Feuil1.Range("D" & Lg), 2)
            Case "LA", "MC"
                  If InStr(1, Feuil1.Range("D" & Lg), "CONFIG") = 0 And Feuil1.Range("F" & Lg) <> "" And Feuil1.Range("L" & Lg) <> "Validé" Then Feuil1.Range("D" & Lg).Interior.Color = RGB(255, 192, 0)
                  If InStr(1, Feuil1.Range("D" & Lg), "CONFIG") = 0 And Feuil1.Range("F" & Lg) = "" And Feuil1.Range("L" & Lg) <> "Validé" Then Feuil1.Range("D" & Lg).Interior.Color = RGB(32, 224, 255)
      End Select
End Sub

en D12

Code:

=SI(ESTERREUR(INDEX(planning!3:3;1;EQUIV(E18;planning!1:1;0)));"";INDEX(planning!3:3;1;EQUIV(E18;planning!1:1;0)))

en E12

Code:

=SI(ESTERREUR(INDEX(planning!5:5;1;EQUIV(E18;planning!1:1;0)));"";INDEX(planning!5:5;1;EQUIV(E18;planning!1:1;0)))

spike29 · 13 Décembre 2020

Bonjour jpb,

Merci pour tes réponses, ça marche parfaitement chez moi.

Concernant le remplissage des cellules col B de la Feuil_suivi par de la couleur.
J'ai essayé de rajouter d'autres cas pour "Select case" et ça ne fonctionne pas.

Autre point, j'aimerai que l'action de remplir la cellule d'une couleur ou d'une autre se fasse dès lors que "LA" ; "MC" etc... est détecté dans la cellule et pas forcément comme premier caractères.
J'imagine que c'est le left de sélect case qu'il faut modifier

VB:

 Select Case Left(Feuil1.Range("D" & Lg), 2)
            Case "LA", "MC", "[TOF]", "FE"

Quelques précisions sur le besoin une fois arrivé à cette étape qui fonctionne déjà parfaitement :

Dès lors qu'il y a du texte en plus de X1,X2 etc.... ( exemple X2 test) comme dans le fichier que j'ai envoyé alors ça ne fonctionne plus.
J'ignore comment faire en sorte que la macro fasse abstraction de l'éventuel texte en plus de X1,X2 etc... ?

L'objectif est que la macro ne prennent en compte que le cellules contenant des n° d'items ( X1,X2 etc...) mais comportant aussi du texte en plus, peu importe lequel celui étant n'étant jamais le même. Si une cellule ne contient que X1, ou X2 etc... l'ignorer et passer à la suivante.

Avec mes fragiles connaissances en VBA je suis incapable de réaliser cela....

Un exemple dans mon fichier des cellules à prendre ou ne pas prendre en compte pour clarifier la totalité du besoin (Détails dans la Feuil_Planning).

Merci d'avance pour votre aide. J'apporte des précisions dans la Feuil_Planning quant aux besoins (pour ne pas surcharger ce message. Le résultat attendu se trouve dans la Feuil Résultat_attendu.

Encore désolé pour ce casse tête chinois mais je serais bien incapable de mettre sur pieds une telle macro sans votre aide.

Bon Dimanche à tous et merci encore.

jpb388 · 14 Décembre 2020

Bonjour à tous
regarde si cela te convient
Bonne soirée

spike29 · 14 Décembre 2020

Bonsoir JPB,

Un énorme merci car c'est exactement ce qu'il me fallait. ça fonctionne à la perfection.

Je n'y serais jamais arrivé seul.

Une seule question et après je n'abuserai plus de ta patience.

Il n'est pas impossible que mes n° d'ITEMS évoluent et passent d'un format X1,X15 à un format TT15, TT234.

Lorsque je fais le test ça ne fonctionne pas.

J'ai essayé de réadapter le code de ce que j'ai réussi à comprendre mais sans grand succès...

D'après ce que j'ai réussi à comprendre, la solution devrait se trouver dans l'un des ces deux bouts de code ci-dessous mais impossible de trouver précisément à quel niveau

VB:

Private Function TrouveZone2$(vCh$)
      Dim Ch&, X As Byte
      For X = 1 To Len(vCh)
            If IsNumeric(Mid(vCh, X, 1)) Then Ch = Ch & Mid(vCh, X, 1)
      Next
      TrouveZone2 = IIf(CInt(Ch) = 0, vCh, CInt(Ch))
End Function

Code:

For I = 1 To Len(Cible)
        If IsNumeric(Mid(Cible, I, 1)) Then
        Nombre = Val(Mid(Cible, I, Len(Cible) - I + 1))
        On Error Resume Next
        ReDim Preserve Resultat(UBound(Resultat) + 1)
        If Err.Number > 0 Then ReDim Preserve Resultat(1): On Error GoTo 0
        Resultat(UBound(Resultat) - 1) = Mid(Cible, I - 1, 1) & Nombre
        I = I + Len(Str(Nombre)) - 1
        End If
    Next
    extraireValeursNumeriques_DansChaine = Resultat
End Function

Merci d'avance pour ton aide et ta patience sans failles

Bonne fin de jounée

jpb388 · 15 Décembre 2020

Bonjour à tous
des chiffres avec 1 lettre c'est ok a condition que tu l'a mis dans le data
avec plusieurs lettres je vais y réfléchir mais pas avant jeudi
bonne journée

spike29 · 15 Décembre 2020

Bonsoir jpb et merci pour ton retour.

Oui, j'ai fais le test justement en modifiant dans la Feuil Data. Tant qu'il y a une seule lettre pas de soucis, il suffit de mettre correctement à jour et cela fonctionne.

Pas de problème j'attend ton retour

En tout cas un grand merci à toi de te pencher sur mes demandes loin d'être évidentes...

Bonne fin de journée à toi

jpb388 · 17 Décembre 2020

Bonjour à tous
pas fait de test tu me diras

spike29 · 17 Décembre 2020

Bonsoir jpb et merci pour ton retour.

Alors j'ai fais le test et ça ne fonctionne pas à l'exception d'une valeur (TT15 en l'occurrence) pour laquelle je ne m'explique pas qu'elle soit la seule à marcher.

En PJ, le retour de ton fichier avec la modification apporté aux n° d'ITEMS (avec cette fois ci un format de type "TT01" ou "TT15" ou "TT412" par exemple.

Bonne fin de journée et merci d'avance pour ton retour

jpb388 · 18 Décembre 2020

Bonjour à tous
je recherche les chiffres et un 0 devant un chiffre = "" comme 03 c'est égal à 3 autrement dit au lieu d'avoir TT03 j'avais TT3 d'où l'erreur
fais tes tests et dis moi
a+

XL 2010 VBA copie données d'une Feuil à l'autre + MFC

spike29

XLDnaute Occasionnel

Pièces jointes

Rouge

XLDnaute Impliqué

spike29

XLDnaute Occasionnel

jpb388

XLDnaute Accro

spike29

XLDnaute Occasionnel

jpb388

XLDnaute Accro

jpb388

XLDnaute Accro

spike29

XLDnaute Occasionnel

Pièces jointes

jpb388

XLDnaute Accro

Pièces jointes

spike29

XLDnaute Occasionnel

jpb388

XLDnaute Accro

spike29

XLDnaute Occasionnel

jpb388

XLDnaute Accro

Pièces jointes

spike29

XLDnaute Occasionnel

Pièces jointes

jpb388

XLDnaute Accro

Pièces jointes

Discussions similaires