bonjour,
version adaptée pour personnel qui ne serait pas toujours dans la même colonne
Sub aargh()
'voici l'algorithme :
'1) choisir le répertoire
'2) choisir l'année
'3) parcourir tous les fichiers du répertoire pour cette année qui ont le bon format *.*.annee.xls
'4) ouvrir le fichier
'5) parcourir toutes les lignes du bulletin
'6) trouver dans synthèse l'onglet de la spécialité pour cette ligne
'7) trouver dans cet onglet, l'activité pour cette ligne
'8) si activité n'existe pas on l'ajoute
'9) parcourir toutes les colonnes de cette ligne du bulletin
'10) si valeur 1 détectée,
' 10.1) on recherche la personne dans l'onglet spécialité
' 10.2) si trouvé on ajoute 1 au compteur de cette personne pour cette activité
'11) on passe à la colonne suivante ->10)
'12) on passe à la ligne suivante ->6)
'13) on ferme le fichier
'14) on passe au fichier suivant ->4)
Set twb = ThisWorkbook
With Application.FileDialog(msoFileDialogFolderPicker) 'choix du répertoire
.AllowMultiSelect = False
.Title = "Choisir le répertoire contenant les fichiers à consolider"
If .Show = True Then
rep = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
anac = Val(InputBox("année à consolider")) 'choix de l'année à consolider
If Len(anac) < 4 Then anac = 2000 + anac
If anac = 0 Then Exit Sub
nf = rep & "*.*." & Format(anac, "0000") & ".xls*"
nf = Dir(nf)
While nf <> "" 'on examine les fichiers de l'année qui ont le format *.*.année.xls*
Application.StatusBar = "consolidation fichier " & nf
Application.DisplayAlerts = False
Set wb = Workbooks.Open(rep & nf, UpdateLinks:=False) 'ouverture du fichier
Set ws = wb.Sheets("bulletin") 'selection du bulletin
Application.DisplayAlerts = True
dl = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To dl ' pour chaque ligne du bulletin
ns = ws.Cells(i, 1)
If ns = "" Then Exit For
Set wst = twb.Sheets(ns) 'on ouvre l'onglet correspondant à la spécialité
dlt = wst.Cells(4, 1).End(xlDown).Row
Set plagewst = wst.Range("A4:A" & dlt)
Set re = plagewst.Find(ws.Cells(i, 2), lookat:=xlWhole) 'on recherche la technique dans l'onglet de la spécialité
If re Is Nothing Then 'si pas trouvée on l'ajoute
wst.Rows(dlt).Copy
wst.Rows(dlt + 1).Insert Shift:=xlDown
dlt = dlt + 1
wst.Cells(dlt, 1) = ws.Cells(i, 2)
q = dlt
Else
q = re.Row
End If
dc = ws.Cells(i, Columns.Count).End(xlToLeft).Column
For j = 3 To dc 'on compte les personnes qui ont participé
If ws.Cells(i, j) <> "" Then
'recherche du nom dans l'onglet spécialité
Set re = Range(wst.Range("D3"), wst.Cells(3, dc)).Find(ws.Cells(3, j), lookat:=xlWhole, LookIn:=xlValues)
If re Is Nothing Then
MsgBox "personnel " & ws.Cells(3, j) & " non trouvé dans l'onglet " & ws.Name
Else
wst.Cells(q, re.Column) = wst.Cells(q, re.Column) + 1
End If
End If
Next j
Next i
wb.Close
nf = Dir
Wend
Application.StatusBar = ""
End Sub