VLOOKUP

  • Initiateur de la discussion KBI
  • Date de début
K

KBI

Guest
Bonjour et Merci pour votre aide par avance,

Le code suivent inclus l'instruction VLOOKUP pour chercher les départements. dans tous les cas elle ne trouve que 'Sortie effectif' et crée une feuille de calcul.
Cliquez pour agrandir...


Code: 
Sub Ajout_Départements()

    
    Dim i As Long, Hauteur As Long, Plage As String, Année As Long
    Dim Feuille_Fichier As String, Département As String
    Dim Fichier_actif As String
    
    Fichier_actif = ActiveWorkbook.Name
    
    Dim Chemin As String, Fichier As String
    
    'chemin = 'd:\\fr53237n\\donnees\\appli plan formation\\'
    Chemin = Range('A9')
    Fichier = Range('A13')
    
    Année = Application.InputBox('Année à considérer ?', 'Année', Year(Date), , , , , 1)
    
    Sheets('Patience...').Visible = True
    
    Sheets('patience...').Select
    
    Application.ScreenUpdating = False
    
    Workbooks.Open (Chemin & 'Depart service PF.xls')
    
    Workbooks.Open (Chemin & Fichier)
    
    Feuille_Fichier = ActiveSheet.Name
    
    Hauteur = Range('A1').CurrentRegion.Rows.Count
    

    Columns('J:J').Select
    Selection.NumberFormat = 'General'
    
' boucle de conversion des codes services en numérique
'    Hauteur = 4
    For i = 2 To Hauteur
       If Cells(i, 10) <> '     ' Then Cells(i, 10) = CLng(Cells(i, 10))
  Next
    
' boucle de rapatriement du département
    
  
    Range('L1') = 'Département'
    Range('L2').Select
    i = 2
    Do While i <= Hauteur

      
        If Cells(i, 10) <> '    ' And Cells(i, 9) = '   ' Then
       
            ActiveCell = '=VLOOKUP(RC[-2],'Depart service PF.xls'!recherche,3,FALSE)'
        Else
            ActiveCell = 'Sortie effectif'
        End If
        i = i + 1
        ActiveCell.Offset(1, 0).Select
    Loop
    
' copie en valeurs des résultats extraits
        
    
    Plage = 'L2:L' & Hauteur
    Range(Plage).Copy
    Range(Plage).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False

    ' copie du format du titre Département
    
    Range('K1').Copy

    
    
     Range('L1').PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:= _
     False, Transpose:=False
    
    Application.CutCopyMode = False
    
    Columns('L').ColumnWidth = 25

' extraction des différents départements utilisés
    
    Range('L1').Copy 'KBI
   
    Range('N1').Select
    ActiveSheet.Paste
    
    
    Range('N3').Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
' filtre élaboré extraction
    
    Plage = 'A1:L' & Hauteur
   
    
    Range(Plage).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
        ('N1:N2'), CopyToRange:=Range('N3'), Unique:=True
    
'tri par départ alpha
    
    
    Range('N3').Sort Key1:=Range('N3'), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


' copie de la liste des départements sur la feuille DEPARTEMENTS
    ' du fichier TRAITEMENTS
    
    Windows(Fichier_actif).Activate
    Sheets('Départements').Select
    Columns('A').Clear
    Range('A1').Select
    Windows(Fichier).Activate
    
    
    Range('N3').CurrentRegion.Copy
    Windows(Fichier_actif).Activate
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    Range('D1') = Année
    
    Windows(Fichier).Activate
' tri du fichier par département
    
    
    Range('L1').Select
    
    Selection.Sort Key1:=Range('L1'), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  
    
' copie dans des feuilles distinctes
    
    
    Range('N4').Select
    i = 2 ' pour boucle sur la liste complète
    
    Do While ActiveCell <> '' ' boucle sur les départements
    
        Département = ActiveCell
        Sheets.Add
        ActiveSheet.Name = Département
        
        Sheets(Feuille_Fichier).Select
        
        
        Range('A1:L1').Copy
        Sheets(Département).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Range('A2').Select
        Sheets(Feuille_Fichier).Select
        
        Do While Cells(i, 10) = Département
            
            Plage = 'A' & i & ':L' & i
            Range(Plage).Copy
            Sheets(Département).Select
            ActiveSheet.Paste
            ActiveCell.Offset(1, 0).Select
            Sheets(Feuille_Fichier).Select
            i = i + 1
        Loop
            
        ActiveCell.Offset(1, 0).Select ' va sur le départ suivant
        
    Loop
    Application.CutCopyMode = False
    
    Windows(Fichier).Activate
    
    Range('L4').Select
    
    Do While ActiveCell <> ''
         
        Département = ActiveCell
         
' ouverture du fichier modèle
        
        Workbooks.Open (Chemin & 'Modèle PF Département.xls')
        Sheets('Salariés').Select
        Cells.Clear
        Range('A1').Select
        
        Windows(Fichier).Activate
        Sheets(Département).Select
        Range('A1').CurrentRegion.Copy
        Windows('Modèle PF Département.xls').Activate
        
        ActiveSheet.Paste
        
' concaténation sur la feuille des salariés
        Sheets('Salariés').Select
        Columns('A:A').Select
        Selection.Insert Shift:=xlToRight
        
' écriture du chemin d'accès au fichier SGP pour accès ultérieur (maj fichier salariés
' en cours d'élaboration du plan de formation
        
        Range('M1') = 'Chemin SGP :'
        Range('N1') = Chemin
        Range('O1') = 'Fichier SGP :'
        Range('P1') = Fichier
        
        ActiveWorkbook.Names.Add Name:='Chemin_SGP', RefersTo:='=Salariés!$N$1'
        ActiveWorkbook.Names.Add Name:='Fichier_SGP', RefersTo:='=Salariés!$P$1'
        
        Range('A1').Select
        ActiveCell.FormulaR1C1 = 'Choix ' & Département
        Range('A2').Select
        Hauteur = Range('B1').CurrentRegion.Rows.Count
       
        ActiveCell.FormulaR1C1 = _
           '=TRIM(RC[2])&'' ''&TRIM(RC[3])&'' (''&TRIM(RC[9])&'')'''
        Plage = 'A2:A' & Hauteur
        If Hauteur > 2 Then
            Selection.AutoFill Destination:=Range(Plage)
        End If
        Columns('A:A').EntireColumn.AutoFit
              
        Range('A1').Select
        Selection.Sort Key1:=Range('A1'), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
        ' fige en valeur la concaténation
        Range(Plage).Copy
        Range(Plage).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
           False, Transpose:=False
        Application.CutCopyMode = False
        Rows('2:2').Select
        Selection.Insert Shift:=xlDown
        Selection.Interior.ColorIndex = xlNone
        Range('A2') = 'Non nominatif'
        Range('J2') = ' Non précisé' 'espace volontaire pour tri des services
            
' définition des règles de validation
            
        Plage = '$A$2:$A$' & Hauteur + 1
            
        ActiveWorkbook.Names.Add Name:='noms', RefersTo:='=Salariés!' & Plage
        
        ' nomme la plage de recherche 'Liste_Salariés'
        Plage = '$A$2:$K$' & Hauteur + 1
            
        ActiveWorkbook.Names.Add Name:='Liste_Salariés', RefersTo:='=Salariés!' & Plage
        
'----------------- EXTRACTION DE LA LISTE DES SERVICES -------------------------
        
        Range('M3') = 'Libelle_service'
        Range('M5') = 'Libelle_service'
        Range('A1').CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
            'M3:M4'), CopyToRange:=Range('M5'), Unique:=True
        
        ' définition du nom sur la liste des services
        
        Plage = '$M$6:$M$' & Range('M6').CurrentRegion.Rows.Count + 4
        
        Range(Plage).Sort Key1:=Range('M6'), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
        ActiveWorkbook.Names.Add Name:='Liste_Services', RefersTo:='=Salariés!' & Plage
        
'-----------------FIN EXTRACTION DE LA LISTE DES SERVICES ------------------------
        
        Sheets('Détail PF').Select
        
        ' règles de validation en liste pour proposer le nom /prénom / service
        
        With Range('A5:A2000').Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:='=noms'
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ''
            .ErrorTitle = 'Erreur'
            .InputMessage = ''
            .ErrorMessage = 'Ce salarié n'existe pas'
            .ShowInput = True
            .ShowError = True
        End With
        
' règles de validation en liste pour proposer les services possibles
        
        With Range('C5:C2000').Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:='=Liste_Services'
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ''
            .ErrorTitle = 'Erreur'
            .InputMessage = ''
            .ErrorMessage = 'Ce service n'existe pas. Choisissez NON PRECISE le cas échéant'
            .ShowInput = True
            .ShowError = True
        End With
            
        Sheets('Détail PF').Select
        Range('E1') = 'PLAN DE FORMATION ' & Année & ' - ' & Département
            
            
        ActiveWorkbook.SaveAs (Chemin & 'PF ' & Année & ' - ' & Département)
        ActiveWorkbook.Close
        
        Windows(Fichier).Activate
        
        Sheets(Feuille_Fichier).Select
        
        ActiveCell.Offset(1, 0).Select

    Loop
         
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close
    
    Windows('depart service PF.xls').Activate
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close
    
    Windows('Traitements.xls').Activate
    
    Sheets('Patience...').Visible = False
    
    Sheets('Menu').Select
    
    Application.ScreenUpdating = True

End Sub
 
Trier par date Trier par votes
chris

chris

XLDnaute Barbatruc
BOnjour

Inutile de mettre tout le code, la partie concernée suffit.

If Cells(i, 10) <> ' ' And Cells(i, 9) = ' ' Then
Cliquez pour agrandir...

Ton test de contenu des cellules est bizzare : 1 ou plusieurs espaces ?

Que cherches-tu à tester en fait ?

Si c'est vide ou non vide, il ne faut rien mettre entre les '
Perso je prèfère utiliser la fonction Isempty.
 
Vote positif 0 Vote négatif

Discussions similaires

ph.vanne
  • Question
Autres fenêtre "Publication"
Réponses
10
Affichages
270
ph.vanne
ph.vanne
Chaton77
  • Résolu(e)
Microsoft 365 Vba : Transférer des données d'un tableau dans un autre fichier
Réponses
7
Affichages
329
Chaton77
Chaton77
J
  • Question
Microsoft 365 Code VBA
Réponses
10
Affichages
699
jebibo
J
F
  • Question
Microsoft 365 Poursuivre ou pas la macro
Réponses
2
Affichages
353
Francky79
F
P
  • Question
XL 2019 Changer nom d'export en VBA
Réponses
3
Affichages
416
job75
job75
mouchtre
  • Résolu(e)
Microsoft 365 Macro fonctionnant avec excel 365 sur windows 11 mais ne fonctionnent pas sur un autre windows 11 avec aussi un excel 365
Réponses
11
Affichages
800
mouchtre
mouchtre
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
AtTheOne
X
  • Question
XL 2016 Copier à partir de la dernière ligne renseignée.
Réponses
8
Affichages
610
Xender
X
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
848
Nicolas JACQUIN
Nicolas JACQUIN
U
  • Question
Autres [RÉSOLU] Problème macro mais lequel?
Réponses
4
Affichages
514
un internaute
U

Membres actuellement en ligne

2 membres et 45 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 499
Messages
2 110 249
Membres
110 711
dernier inscrit
chmessi