Transferer valeur sous conditions

[jeannot68]

Bonjour

Mon souci est de transfere des info vers un fichier et vers des cellule bien precise.

Mon but est de renplir mon fichier "HEURES MTE FEVRIER" en fonction du fichier "TRAVAUX REALISES"

La macro doit d'abord en quelque sorte faire un filtre (fichier TRAVAUX REALISE") dans la colonne G et choisir MTE. ensuite en fonction du nom (colonne C) et de la date (colonne B) copier la valeur de la colonne D et coller cette info dans le fichier HEURES MTE FEVRIER correspondant au bon nom onglet et a la bonne date et coller l info en colonne C

Si jamais plusieurs travaux sont dans la meme journée mettre un + entre.

un exemple est plus parlant dans les fichiers joints avec.

Merci de votre aide

 

[Robert]

Re : Transferer valeur sous conditions

Bonjour Jeannot, bonjour le forum,

je te propose la macro ci-dessous :

Sub Macro1()
Dim c As Workbook 'déclare la variable c (classeur Cible)
Dim t As Worksheet 'déclare la variable t (onglet Travaux)
Dim oc As Worksheet 'déclare la varialbe oc (Onglet Cible)
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim j As Byte 'déclae la variable j (Jour)
Dim h As Byte 'déclare la variable h (Heures)
Dim dest As Range 'déclare la varialbe dest (DESTination)
 
Set c = Workbooks("HEURES MTE FEVRIER.xls") 'définit la variable c
Set t = Sheets("Travaux") 'définit la variable t
Set pl = t.Range("G2:G" & t.Range("G65536").End(xlUp).Row) 'définit la variable pl
 
For Each cel In pl 'boucle sur toutes les cellules éditées cel de la plage pl
    If cel.Value = "MTE" Then 'condition : si la valeur de la cellule cel est égale à "MTE"
        Set oc = c.Sheets(cel.Offset(0, -4).Value) 'définit l'onglet cible
        j = Day(cel.Offset(0, -5).Value) 'définit le jour
        h = cel.Offset(0, -2).Value 'définit les heures
        Set dest = oc.Range("A4:A" & oc.Range("A3").End(xlDown).Row).Find(j, , xlValues, xlWhole) 'définit la destination
        Select Case dest.Offset(0, 1).Value 'agit en fonction du nombre heures de la destination
            Case "" 'si vide
                dest.Offset(0, 1).Value = h 'place les heures
                dest.Offset(0, 2).Value = cel.Offset(0, -3).Value 'place le texte
            Case Else 'si non vide
                dest.Offset(0, 1).Value = dest.Offset(0, 1).Value + h 'ajoute les heures
                dest.Offset(0, 2).Value = dest.Offset(0, 2).Value & " + " & cel.Offset(0, -3).Value 'ajoute le texte
        End Select 'fin de l'action en fonction de...
    End If 'fin de la condition
Next cel 'prochaine cellule cel de la boucle
End Sub

 

[job75]

Re : Transferer valeur sous conditions

Bonjour jeannot68, salut Robert

Ca m'ennuie de venir sur tes plates-bandes, Robert, mais je sais que tu ne m'en voudras pas.

Puisque je l'ai écrite, voici ma macro :

Private Sub CommandButton1_Click()
Dim nomfich$, w As Worksheet, cel As Range
nomfich = "HEURES MTE FEVRIER.xls"
Application.DisplayAlerts = False
On Error Resume Next
Workbooks.Open ThisWorkbook.Path & "\" & nomfich 'chemin d'accès à adapter éventuellement
If Err Then MsgBox nomfich & " introuvable": Exit Sub
'Effacement des données---
For Each w In Workbooks(nomfich).Worksheets
  w.Range("B4:C34").ClearContents
Next
'Ventilation des données---
For Each cel In Me.Range("B2", Me.Range("B65536").End(xlUp))
  With Workbooks(nomfich).Sheets(cel.Offset(, 1).Text).Cells(Day(cel) + 3, 3) 'colonne C
    .Offset(, -1) = .Offset(, -1) + cel.Offset(, 3) 'colonne B
    .Value = .Value & IIf(.Value = "", "", " + ") & cel.Offset(, 2)
  End With
Next
End Sub

Cliquer sur le bouton Ventiler du fichier TRAVAUX REALISES.

Les 2 fichiers doivent être mis dans le même répertoire (le bureau par exemple).

A+

 

[Robert]

Re : Transferer valeur sous conditions

Bonjour le fil, bonjour le forum,

Ha la gueule des plates-bandes ! Ha ça, je t'en voudrais plutôt du contraire car c'est grâce à ces "empiètements" que je progresse et que nous progressons tous. Merci Job au contraire !

 

[jeannot68]

Re : Transferer valeur sous conditions

Bonjour Robert, job75 et le forum

J'ai bien essayé vos 2 solutions afin de voir quelles plate bande correspond le mieux

Robert: a partir du 15 février il me manque les lignes; y a t il une limite??

Job 75 si j ajoute d autre ligne supplementaire cela s arrete aussi a des ligne bien avant la fin du mois

Y a til donc une limite a la macro??

 

[Robert]

Re : Transferer valeur sous conditions

Bonjour le fil, bonjour le forum,

Jeannot chez moi ça fonctionne ! En pièces jointes tes fichiers exemple où j'ai juste rajouté quelques lignes...

 

[job75]

Re : Transferer valeur sous conditions

Re,

Job 75 si j ajoute d autre ligne supplementaire cela s arrete aussi a des ligne bien avant la fin du mois

Par cette instruction :

For Each cel In Me.Range("B2", Me.Range("B65536").End(xlUp))

toutes les cellules avant la dernière sont étudiées en colonne B de la feuille TRAVAUX REALISES.

Mais le filtre automatique ne doit pas être en place, car alors la "dernière cellule" est définie sur les cellules visibles uniquement.

A+

 

[job75]

Re : Transferer valeur sous conditions

Re,

Pour que ça fonctionne bien même avec le filtre automatique en place, vous pouvez remplacer :

For Each cel In Me.Range("B2", Me.Range("B65536").End(xlUp))

par :

For Each cel In Intersect(Me.UsedRange, Me.Columns(2))

A+

 

[jeannot68]

Re : Transferer valeur sous conditions

Job75

Ca y est ca marche mais j ai un autre probleme il a des travaux qui apparaissent et qui ne devrais pas. Je souhaite justeles travaux ou le donneur colonne G de travaux a réalisé est égale a MTE.

De plus, admettons que je clique au milieu du mois les données sont transferé je modifie certaines chose j enregisre et comment faire pour que a la fin du mois je puisse rajouté les dernieres donnée a transferer sans toucher a ceux du debut du mois que j ai modifié.

Avant je mettais un petit F dans la colonne A du fichier travaux a realiser qui colorie la ligne. en fonction de cela peut on faire en sorte qui si F est dans colonne A alor on ne change plus les donnnées qui dans le fichier HEURES MTE FEVRIER

De plus, cmment faire quand le mois de mars arrive. peut on faire quelque chose pour eviter de changer a chaque fois les noms??

Merci de votre aide

 

[job75]

Re : Transferer valeur sous conditions

Re,

Je joins le fichier modifié comme indiqué, avec le filtre automatique activé.

A+

 

[job75]

Re : Transferer valeur sous conditions

Re,

Nos posts se sont croisés.

En réponse à votre post #9 voici déjà une modification de la macro :

- elle n'efface plus bien sûr les données au début

- elle met un "f" en colonne A de la ligne traitée

- seules les données avec MTE en colonne G sont traitées (j'avais mal lu le 1er post, désolé).

Private Sub CommandButton1_Click()
Dim nomfich$, w As Worksheet, cel As Range
nomfich = "HEURES MTE FEVRIER.xls"
[COLOR="Red"]Application.ScreenUpdating = False 'fige l'écran[/COLOR]
Application.DisplayAlerts = False
On Error Resume Next
Workbooks.Open ThisWorkbook.Path & "\" & nomfich 'chemin d'accès à adapter éventuellement
If Err Then MsgBox nomfich & " introuvable": Exit Sub
'---Ventilation des données---
For Each cel In Intersect(Me.UsedRange, Me.Columns(2))
  [COLOR="Red"]If cel.Offset(, -1) = "" And cel.Offset(, 5) = "MTE" Then 'si colonne A vide et MTE en colonne G
    cel.Offset(, -1) = "f" 'au lieu d'effacer les données[/COLOR]
    With Workbooks(nomfich).Sheets(cel.Offset(, 1).Text).Cells(Day(cel) + 3, 3) 'colonne C
      .Offset(, -1) = .Offset(, -1) + cel.Offset(, 3) 'colonne B
      .Value = .Value & IIf(.Value = "", "", " + ") & cel.Offset(, 2)
    End With
  [COLOR="red"]End If[/COLOR]
Next
[COLOR="Red"]ThisWorkbook.Save 'enregistrement
Workbooks(nomfich).Save[/COLOR]
End Sub

Pour le changement de mois, ça ne pose pas de problème bien difficile mais que voulez vous faire ? Un nouveau fichier chaque mois ? Dans ce cas je passe la main.

A+

 

[job75]

Re : Transferer valeur sous conditions

Re,

Ah oui, mais il faut tout enregistrer à la fin, sinon problème si l'on reclique sur le bouton...

J'édite le post précédent.

A+

 

[jeannot68]

Re : Transferer valeur sous conditions

OK MERCI POR TON AIDE

je vais un peu bosser avec et voir ce que je pourrai ameliorer.
encore merci pour ton aide rapide et efficace.

Et merci a toi robert.

Bonne fin de journée