Réalisé une macro en fonction du nom

Résolu
Akre66 Messages postés 57 Statut Membre -  
Akre66 Messages postés 57 Statut Membre -
Bonjour,
Je suis à ma 2eme macro donc je suis assez jeune dans la VBA.
J'ai realisé une macro il y a un mois. Mais je cherche à l'optimiser.
Dans un fichier excel, des gens "imputent" leurs heures sur des différents projets. Chaque individus appartient à une section, avec un chef.
Le chef doit imputer ses heures en fonction des heures imputé par son equipe.

Exemple 

Equipe A:
Projet 1: 500 heures
Projet 2: 300 heures
Projet 3: 200 heures

Du coup le chef impute 50% sur le projet 1, 30 et 20 sur le 2 et 3.

Alors pour l'instant ma macro récupéré bien les noms des projets, leurs descriptions, leurs heures puis pondère. Mais j'ai des difficultés sur un point.
L'opérateur doit rentrer un nom (à partir d'un menu déroulant) que ma macro associe à une équipe, donc à une liste de personne. Et du coup je dois réaliser ce que j'ai fait avec mon début de macro, mais uniquement pour les membres de l'équipe sélectionné.
Et là je plante... Du coup si vous avez une idée.
J'ai commencé à tester la présence du nom de famille (j'ai que ça) dans la colonne A (où sont les noms complets), si le test est bon je copie la ligne sur une nouvelle feuille nommé du nom de l'équipe... Pour après lancer ma macro sur cette nouvelle feuille.
Je me doute bien que c'est pas du tout bien niveau temps et tout... Mais j'ai pas trop d'idée.
Voilà ma macro : 


Option Explicit
 
Sub Imputation()
 
'Declaration des variables
 
Dim CellActive As Range
Dim Celltowrite As Range
Dim Cell_test As Range
Dim celluletrouvee As Range
Dim Cell As Range, Cell_nom As Range
Dim Plage As Range, Plage_nom As Range
Dim Membre As Range
Dim Trouve As Range
 
Dim FSource As Worksheet
Dim FCible As Worksheet
Dim FCible_bis As Worksheet
Dim Feuille As Worksheet
 
Dim Un As Collection
Dim Deux As Collection

Dim ssdoublon()

Dim Section As String
Dim Nom As String
Dim Description As String
Dim Nom_bis As String

Dim dl As Long, dl_bis As Long
Dim Heure As Long
Dim Dec As Long
Dim Sum As Long
Dim Colonne As Long
Dim b As Long
Dim i As Long, n_ligne As Long, a As Long
Dim num_ligne As Long

'On récupère les valeurs données par l'opérateur
'Feuille Source
Set FSource = Worksheets("Cmd")
Section = FSource.Range("B2").Value

For i = 1 To Worksheets.Count
    If Worksheets(i).Name = Section Then
        Sheets(Section).Delete
    End If
Next i

Sheets.Add Worksheets(1)
Sheets(1).Name = Section

Set FCible_bis = Worksheets(Section)

'On récupère la liste des membres
Set FCible = Worksheets("Ar_plan")

'On va parcourir la liste des sections
Set celluletrouvee = FCible.Range("A2:Z2").Find(Section, LookAt:=xlWhole)

If celluletrouvee Is Nothing Then
MsgBox ("Pas trouvé de section")
Else
Colonne = celluletrouvee.Column
End If

'On va parcourir la liste des membres
b = 0

Set Plage = FCible.Range(celluletrouvee, celluletrouvee.End(xlDown)).Rows
For Each Membre In Plage
   Nom = Membre.Value
   'MsgBox (Membre.Value)
   
'On formate le nom
Nom_bis = Mid(Nom, 3, Len(Nom))
   
    FSource.Cells(20 + b, 20) = Nom_bis

'On va chercher les valeurs données
'Feuille Cible
    Set FCible = Worksheets("DATA")

Set Plage = FCible.Columns("A")
   
 For Each Cell_nom In Plage
'    If Cell_nom.Text Like ("*" & Nom_bis & "*") Then
    If Cell_nom.Text Like ("Mlle MAUD BLANDIN") Then
    MsgBox ("BRAVO")
    FCible.Rows(Cell_nom.Row).Select
    Selection.Copy
    Worksheets(Section).Cells(num_ligne, 1).Select
    Selection.Paste
    num_ligne = num_ligne + 1
    End If
 Next Cell_nom

'On va prendre uniquement les membres de la section
    
With ActiveSheet
   dl = FCible.Range("D" & .Rows.Count).End(xlUp).Row
End With
Set Plage = FCible.Range("D2:D" & dl)
Set Un = New Collection
On Error Resume Next
 
'On parcourt la plage de donnée
For Each Cell In Plage
   If Cell <> "" Then Un.Add Cell, CStr(Cell) 'Si la valeur est différent des autres on la prends sinon on passe
Next Cell

For i = 1 To Un.Count
   ReDim Preserve ssdoublon(i - 1)
   ssdoublon(i - 1) = Un.Item(i)
  Next i
  
Heure = 0 'on inialise

For i = 0 To UBound(ssdoublon)
  ' MsgBox ssdoublon(i)
  ' à la place remplis ta listbox
  'On ecrit le projet sur notre ligne de sortie

n_ligne = 2
'Set Celltowrite = FSource.Cells(n_ligne, 1)
FSource.Cells(n_ligne + i, 5) = ssdoublon(i)
 
Sum = 0 'on initalise
For Each Cell In Plage
If Cell = ssdoublon(i) Then Sum = Sum + Cell.Offset(0, 2).Value
'Si le projet est le bon on récupère son heure
If Cell = ssdoublon(i) Then Description = Cell.Offset(0, 1).Value

Next Cell
'On écrit la somme des heures travaillées sur un projet
FSource.Cells(n_ligne + i, 6) = Description
FSource.Cells(n_ligne + i, 7) = Sum
'On somme les heures (pour avoir la somme des heures totales)
Heure = Heure + Sum
 
Next i
'On écrit la somme des heures travaillées
FSource.Cells(n_ligne + i, 7) = Heure

For a = 0 To i
'On caclule les pourcentages et on l'écrit
FSource.Cells(n_ligne + a, 8) = FSource.Cells(n_ligne + a, 7) / Heure
'On calcule le nombre d'heure à impuer et on l'écrit
FSource.Cells(n_ligne + a, 9) = FSource.Cells(n_ligne + a, 8) * FSource.Cells(2, 3)

'On va arrondir les valeurs
FSource.Cells(n_ligne + a, 10) = Round(FSource.Cells(n_ligne + a, 9))
Next a

Sum = 0
Heure = 0

'On va calculer les sommes
For a = 0 To i - 1
Sum = Sum + FSource.Cells(n_ligne + a, 8)
Heure = Heure + FSource.Cells(n_ligne + a, 9)
Next a
'On les écrit
FSource.Cells(a + 2, 9) = Sum
FSource.Cells(a + 2, 9) = Heure
FSource.Cells(a + 2, 5) = "Total"

Set Un = Nothing

'On passe à la personne suivante
b = b + 1
Next Membre
 
End Sub


Merci de votre aide,
Si besoin je peux vous donner un modèle du fichier excel, mais ça sera pas le vrai.

Après je me demande comment je pourrai trier mon tableau de sortie dans l'ordre croissant des heures à mettre la colonne J.

EDIT:
Alors j'arrive pas à comparer la cellule et les noms, ça marche pas ! Je comprends pas ! Je vise bien la bonne cellule (j'ai testé), quand je remplace le nom par "a" et (mets "a" dans le colonne) ça marche pas...donc l'erreur vient de mon like mais je vois pas pourquoi.

EDIT2:
Je crois voir mon erreur...j'ai mis Cell_nom.text alors que normalement c'est "value" qui m'interrèse. Mais il y a une incomptabilité du coup dans le like si je prendre "value"... Bref je suis perdu

3 réponses

  1.
    Akre66 Messages postés 57 Statut Membre
     
    Résolu comme un grand :)
    0
    1. borntobealive Messages postés 167 Statut Membre 7
       
      explique-nous ça pourra toujours servir à quelqu'un
      0
  2. Utilisateur anonyme
     
    Bonjour

    Tu nous a signalé que le souci était résolu.

    La règle sur les forums est que tu viennes nous expliquer comment tu as fait pour que ça puisse servir peut-être à d'autres personnes...

    Merci d'avance,
    Strumpfette, modératrice.
    0
  3. Akre66 Messages postés 57 Statut Membre
     
    Ok désolé j'avais oublié.
    Bon j'ai pas mal fait de modification sur la macro de départ.

    Pour faire simple j'ai fait les processus suivants:
    -Lire le nom du chef
    -Chercher ce nom dans une plage (dans une feuille que j'ai moi même ecrit pour y associer Chef-Section-Membres)
    -Lire un par le nom des membres (format "P.NOM")
    -Je sépare cette cellule pour avoir juste "NOM" 

    'On formate le nom
    Nom_bis = Mid(Nom, 3, Len(Nom))


    -Je parcours la colonne "A" de la feuille ou sont contenus mes informations et test si le nom de famille correspond (format des noms de celle colonnes sont "M. PRENOM NOM"). J'utilise donc "LIKE". Si c'est bon je copie/colle dans une feuille « tampon » (je la supprime après). 
    'On parcourt tous les noms
        For NoLig = 1 To FCible.UsedRange.Rows.Count
            Var = FCible.Cells(NoLig, NoCol)
    'Si le nom correspond à un membre de l'équipe alors on copie la ligne
           If Var Like ("* " & Nom_bis) Then
            FCible.Rows(NoLig).Copy Destination:=FCible_bis.Cells(num_ligne, 1)
            num_ligne = num_ligne + 1
            End If
        Next
    'On passe à la personne suivante
    b = b + 1
    num_ligne = num_ligne + 1
    Next Membre


    Alors je pense bien que le fait de copier/coller soit gourmand. Je sais qu'il y a moyen d'optimiser ça. Mais je voulais avoir la feuille tampon, pour la vérification, le debug et surtout je l'avoue j'avais déjà une macro pour réaliser ça sur une feuille spécfique.
    Après je reste un novice sur VBA, donc si vous avez des suggestions à faire n'hésitez pas. Je vous met ma macro complète (j'ai d'autre trucs).
    Merci :) 


    Option Explicit
     
    Sub Imputation()
     
    'Declaration des variables
     
    Dim celluletrouvee As Range
    Dim Cell As Range, Cellnom As Range
    Dim Plage As Range, Plage_nom As Range
    Dim Membre As Range

    Dim FSource As Worksheet
    Dim FCible As Worksheet
    Dim FCible_bis As Worksheet
     
    Dim Un As Collection

    Dim ssdoublon()

    Dim Section As String
    Dim Nom As String
    Dim Description As String
    Dim Nom_bis As String
    Dim Tampon As Long

    Dim dl As Long, dl_bis As Long
    Dim Heure As Long
    Dim Dec As Long
    Dim Sum As Long
    Dim Colonne As Long
    Dim b As Long
    Dim i As Long, n_ligne As Long, a As Long
    Dim num_ligne As Long

    Dim Condition As Integer
    Dim NoLig As Long, Var As Variant
    Dim NoCol As Integer

    'On récupère les valeurs données par l'opérateur
    'Feuille Source
    Set FSource = Worksheets("Cmd")
    Section = FSource.Range("B2").Value
        
    'Pour eviter les alertes
    With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    End With

    'On récupère le nom de la section
    Sheets.Add Worksheets(1)
    'On crée la feuille tampon
    Sheets(1).Name = "tampon"
    Set FCible_bis = Worksheets("tampon")

    'On récupère la liste des membres
    Set FCible = Worksheets("Ar_plan")

    'On va parcourir la liste des sections
    Set celluletrouvee = FCible.Range("A2:Z2").Find(Section, LookAt:=xlWhole)

    'On envoie un message d'erreur si on trouve rien
    If celluletrouvee Is Nothing Then
    MsgBox ("Pas trouvé de section")
    Else
    'Sinon on se concentre sur cette colonne
    Colonne = celluletrouvee.Column
    End If

    'On va introduire nos conditions(pour la suite)
    Condition = 0
    If Section = "Un" Then Condition = 1
    If Section = "Deux" Then Condition = 2

    'On va parcourir la liste des membres
    b = 0
    num_ligne = 1

    Set Plage = FCible.Range(celluletrouvee, celluletrouvee.End(xlDown)).Rows
    For Each Membre In Plage
       Nom = Membre.Value
       'MsgBox (Membre.Value)
       
    'On formate le nom
    Nom_bis = Mid(Nom, 3, Len(Nom))

    'On va prendre uniquement les membres de la section
    'Feuille Cible
        Set FCible = Worksheets("DATA")
    'On initalise
    NoCol = 1 'lecture de la colonne 1

    'On parcourt tous les noms
        For NoLig = 1 To FCible.UsedRange.Rows.Count
            Var = FCible.Cells(NoLig, NoCol)
    'Si le nom correspond à un membre de l'équipe alors on copie la ligne
           If Var Like ("* " & Nom_bis) Then
            FCible.Rows(NoLig).Copy Destination:=FCible_bis.Cells(num_ligne, 1)
            num_ligne = num_ligne + 1
            End If
        Next
    'On passe à la personne suivante
    b = b + 1
    num_ligne = num_ligne + 1
    Next Membre

    'On va étudier les études de la section
    Set FCible = Worksheets("tampon")

    'On efface les données précédentes
    FSource.Range("E:J").Clear

    'On associe les valeurs à nos colonnes
    FSource.Cells(1, 5) = "NOM OTP"
    FSource.Cells(1, 6) = "Description"
    FSource.Cells(1, 7) = "Heure d'étude"
    FSource.Cells(1, 8) = "Pondération"
    FSource.Cells(1, 9) = "Heure à imputer"
    FSource.Cells(1, 10) = "Arrondi"

    'On cherche la dernière ligne
    With ActiveSheet
       dl = FCible.Range("D" & .Rows.Count).End(xlUp).Row
    End With
    'On défini la nouvelle plage
    Set Plage = FCible.Range("D1:D" & dl)
    Set Un = New Collection
    On Error Resume Next
     
    'On parcourt la plage de donnée
    'On réalise le liste des études sans doublon
    For Each Cell In Plage
       If Cell <> "" And Not IsEmpty(Cell) Then Un.Add Cell, CStr(Cell) 'Si la valeur est différent des autres on la prends sinon on passe
    Next Cell
        
    For i = 0 To Un.Count
       ReDim Preserve ssdoublon(i)
       ssdoublon(i) = Un.Item(i)
      Next i
      
    Heure = 0 'on inialise

    For i = 0 To UBound(ssdoublon)
    If ssdoublon(i) Like "*.*" Then
      ' à la place remplis ta listbox
      'On ecrit le projet sur notre ligne de sortie
    n_ligne = 1

    FCible_bis.Cells(n_ligne + i, 10) = ssdoublon(i)

    Sum = 0 'on initalise
    For Each Cell In Plage
    If Cell = ssdoublon(i) Then Sum = Sum + Cell.Offset(0, 2).Value
    'Si le projet est le bon on récupère son heure
    If Cell = ssdoublon(i) Then Description = Cell.Offset(0, 1).Value
    Next Cell

    'On écrit la somme des heures travaillées sur un projet
    FCible_bis.Cells(n_ligne + i, 11) = Description

    FCible_bis.Cells(n_ligne + i, 12) = Sum
    End If
     Next i

    'On va trier ce tableau

        FCible_bis.Range("J:L").Select
        Selection.Sort Key1:=Range("L2"), Order1:=xlDescending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal

    b = 2
    Heure = 0

    For NoLig = 1 To FCible_bis.Range("J1").End(xlDown).Row
    If Condition = 2 Then
    If Not FCible_bis.Cells(NoLig, 10) Like "F.*" Then
    FCible_bis.Cells(NoLig, 10).Copy Destination:=FSource.Cells(b, 5)
    FCible_bis.Cells(NoLig, 11).Copy Destination:=FSource.Cells(b, 6)
    FCible_bis.Cells(NoLig, 12).Copy Destination:=FSource.Cells(b, 7)
    Heure = Heure + FCible_bis.Cells(NoLig, 12).Value
    b = b + 1
    End If
    End If

    If Condition < 2 Then
    FCible_bis.Cells(NoLig, 10).Copy Destination:=FSource.Cells(b, 5)
    FCible_bis.Cells(NoLig, 11).Copy Destination:=FSource.Cells(b, 6)
    FCible_bis.Cells(NoLig, 12).Copy Destination:=FSource.Cells(b, 7)
    Heure = Heure + FCible_bis.Cells(NoLig, 12).Value
    b = b + 1
    End If
    Next NoLig

    For a = 0 To i - 1

    'On caclule les pourcentages et on l'écrit
    FSource.Cells(n_ligne + a, 8) = FSource.Cells(n_ligne + a, 7) / Heure

    'On calcule le nombre d'heure à impuer et on l'écrit
    FSource.Cells(n_ligne + a, 9) = FSource.Cells(n_ligne + a, 8) * FSource.Cells(2, 3)

    'On va arrondir les valeurs
    FSource.Cells(n_ligne + a, 10) = Round(FSource.Cells(n_ligne + a, 9))
    Next a

    If Condition > 0 Then
    'Condition pour alpha et beta
        For NoLig = 0 To FSource.Range("J1").End(xlDown).Row
            If FSource.Cells(NoLig, 10).Value = 0 Then
            FSource.Cells(NoLig, 10) = ""
            FSource.Cells(NoLig, 9) = ""
            FSource.Cells(NoLig, 8) = ""
            FSource.Cells(NoLig, 7) = ""
            FSource.Cells(NoLig, 6) = ""
            FSource.Cells(NoLig, 5) = ""
            End If
          Next NoLig
      End If

    Sum = 0
    Heure = 0

    'On va calculer les sommes
    For a = 1 To FSource.Range("E1").End(xlDown).Row - 1
    Sum = Sum + FSource.Cells(n_ligne + a, 7)
    Heure = Heure + FSource.Cells(n_ligne + a, 10)
    Next a

    'On les écrit
    FSource.Cells(a + 1, 7) = Sum
    FSource.Cells(a + 1, 10) = Heure
    FSource.Cells(a + 1, 5) = "Total"

    Set Un = Nothing
     Sheets("tampon").Delete
    Application.ScreenUpdating = True

    End Sub

    0
    1. Utilisateur anonyme
       
      Merci d'être revenu et de ton message:)
      Bonne continuation :)
      0
    2. Akre66 Messages postés 57 Statut Membre
       
      Avec plaisir :)
      Je pense à très bientot pour de nouvelles aventures
      0

Discussions similaires

"Nom de l'adresse" lors d'une inscription sur une site
ScarexStupid -
Rossignol -

9 réponses
Nom d’adresse
X -
X -

2 réponses
"Nom de l'adresse" lors d'une inscription sur une site
DAYANA2 -
brucine -

2 réponses
Générateur de Trigramme ou Initiales.
Poctokom -
Jean_33 -

11 réponses
Que faut il écrire dans le champ obligatoire : Adresse (suite)*?
Matisu -
-L0Lock- -

7 réponses