Option Explicit
Dim gsemaine As Integer
Dim gannee As Integer
Private Sub B_quit_Click()
UserForm1.Hide
End Sub
Private Sub b_rech_Click()
Dim conn As New ADODB.Connection
Dim connString
Dim rsRecords As New ADODB.Recordset
Dim rsRecord_badg As New ADODB.Recordset
Dim rsRecord_badg2 As New ADODB.Recordset
Dim affmess As Boolean
Dim rfound As Range
Dim lig As Long
Dim nb_lig, nb_lig_recap, nb_lig_non_aff, nb_lig_recap_stps As Long
Dim nb_lig_stps, vide, nosem, semaine, annee, num_annee As Long
Dim num_lig_dep, dercol, coldeb, nb_col As Long
Dim nbcol As Integer
Dim sdeb, sfin, adeb, afin, sadeb, safin, lib As String
Dim indicateur(4) As String
Dim type_tps(3) As String
Dim code, liste_dep, poste As String
Dim ssaammjj, id_res As Long
Dim i, j, k, lalig, ligsec, col, colrecap, colnonaff, colrecstps, colstps As Integer
Dim trouve, a_traiter, fin_trt, nouvel_op, aucun_badgage As Boolean
Dim nom, prenom, nom_prenom, txtsem, annee_sem, ressource As String
Dim date_traite, datepremjour, date_jour As Date
Dim nb_heure, qte_travaillee As Single
Dim dpt_lu, dpt_traite As String
Dim sh As Range
Dim tableau() As Single
Dim tps_prepa, tps_real, tps_ctrl, tps_total As Single
Dim nbsem As Integer
Dim nbinfo, nbinforecap, nbinfononaff, nbinforecstps, nbinfostps As Integer
Dim dureecons As Integer
Dim posetoile As Integer
num_lig_dep = 3
If Not IsNumeric(sem.Value) Then
MsgBox "La semaine saisie n'est pas numérique."
ann.SetFocus
Exit Sub
End If
nosem = CInt(sem.Value)
If nosem < 1 Or nosem > 52 Then
MsgBox "La semaine saisie doit être comprise entre 1 et 52."
sem.SetFocus
Exit Sub
End If
sem.Value = Format(nosem, "00")
If Not IsNumeric(ann.Value) Then
MsgBox "L'année saisie n'est pas numérique."
ann.SetFocus
Exit Sub
End If
annee = CInt(ann.Value)
ann.Value = Format(ann.Value, "0000")
semaine = nsem(Date)
num_annee = Format(Now, "yyyy")
If semaine = 1 Then
num_annee = num_annee - 1
nosem = 52
Else
semaine = semaine - 1
End If
If ann.Value & sem.Value > num_annee & Format(semaine, "00") Then
MsgBox "La semaine saisie doit être antérieure à la semaine en cours."
sem.SetFocus
Exit Sub
End If
datepremjour = DateSemaineFR(annee, nosem)
connString = "DSN=TOP;Uid=TOPMAN01;Pwd=TOPMAN01"
conn.Open connString
rsRecords.CursorLocation = adUseServer
Set rsRecords = conn.Execute("select rb.date_start as date_debut from resource_calendar rc inner join resource_calendar_band rb on rb.id_resource_calendar = rc.id_resource_calendar where rc.reference = 'METAL 44' and nvl(rb.type,0) = 6 and rb.date_start <= '" & datepremjour & "' and rb.date_end >= '" & datepremjour + 7 & "'")
If Not rsRecords.EOF Then
MsgBox "La semaine demandée correspond à une semaine fermée de l'entreprise."
sem.SetFocus
Exit Sub
End If
rsRecords.Close
Set rsRecords = Nothing
annee_sem = ann.Value & "-" & sem.Value
trouve = False
Worksheets("INDIV").Activate
Worksheets("INDIV").Range("A3").Select
col = 1
Do Until trouve Or IsEmpty(ActiveCell) = True
If annee_sem = Cells(3, col).Value Then
trouve = True
End If
col = col + 1
ActiveCell.Offset(0, 1).Activate
Loop
If trouve Then
MsgBox "La semaine demandée a déjà été traitée."
sem.SetFocus
Exit Sub
End If
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
date_jour = Date
affmess = False
If affmess Then
MsgBox "Initialisation de la feuille 'INDIV'."
End If
nbsem = 52
nbinfo = 2
nbinforecap = 4
nbinfononaff = 3
nbinforecstps = 1
nbinfostps = 2
dureecons = 8
Worksheets("INDIV").Cells.Font.ColorIndex = 1
Worksheets("INDIV").Cells.Font.Bold = False
nb_lig = Worksheets("INDIV").Range("A65536").End(xlUp).Row
nb_lig_recap = Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row
nb_lig_recap_stps = Worksheets("RECAP_SANS_TEMPS").Range("A65536").End(xlUp).Row
lib = Trim("TOTAL ENTREPRISE : ")
If nb_lig_recap_stps > num_lig_dep Then
Worksheets("RECAP_SANS_TEMPS").Activate
With Worksheets("RECAP_SANS_TEMPS")
Set rfound = .Range("A4:A" & nb_lig_recap_stps).Find(lib, LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Cells(lalig, 1).EntireRow.Delete
nb_lig_recap_stps = nb_lig_recap_stps - 1
Set rfound = Nothing
End If
End With
End If
nb_lig_stps = Worksheets("QTE_SANS_TEMPS").Range("A65536").End(xlUp).Row
Worksheets("QTE_SANS_TEMPS").Activate
Worksheets("QTE_SANS_TEMPS").Range("A3").Select
colstps = 1
Do Until IsEmpty(ActiveCell) = True
colstps = colstps + 1
ActiveCell.Offset(0, 1).Activate
Loop
If colstps > nbinfostps + nbsem Then
Columns(nbinfostps + 1).Delete
colstps = colstps - 1
End If
Cells(3, colstps) = annee_sem
nb_lig_non_aff = Worksheets("RECAP_NON_AFF").Range("A65536").End(xlUp).Row
If nb_lig < num_lig_dep Then
nb_lig = num_lig_dep
Else
Worksheets("INDIV").Activate
indicateur(0) = "MOYENNE"
With Worksheets("INDIV")
Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(0), LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Cells(lalig, 1).EntireRow.Delete
nb_lig = nb_lig - 1
Set rfound = Nothing
End If
End With
indicateur(1) = "ECART-TYPE"
With Worksheets("INDIV")
Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(1), LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Cells(lalig, 1).EntireRow.Delete
nb_lig = nb_lig - 1
Set rfound = Nothing
End If
End With
With Worksheets("INDIV")
indicateur(2) = "ECART-TYPE/MOYENNE"
Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(2), LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Cells(lalig, 1).EntireRow.Delete
nb_lig = nb_lig - 1
Set rfound = Nothing
End If
End With
With Worksheets("INDIV")
indicateur(3) = Trim("NB PERS. N'AYANT PAS BADGEES")
Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(3), LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Cells(lalig, 1).EntireRow.Delete
nb_lig = nb_lig - 1
Set rfound = Nothing
End If
End With
With Worksheets("INDIV")
indicateur(4) = Trim("NB PERS. AYANT BADGEES")
Set rfound = .Range("A4:A" & nb_lig).Find(indicateur(4), LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Cells(lalig, 1).EntireRow.Delete
nb_lig = nb_lig - 1
Set rfound = Nothing
End If
End With
End If
nb_lig = Worksheets("INDIV").Range("A65536").End(xlUp).Row
lig = 3
Worksheets("INDIV").Activate
If col > nbinfo + nbsem Then
Columns(nbinfo + 1).Delete
col = col - 1
End If
Cells(3, col).Value = ann.Value & "-" & sem.Value
Worksheets("RECAP_SEM").Activate
Worksheets("RECAP_SEM").Cells.Font.ColorIndex = 1
Worksheets("RECAP_SEM").Cells.Font.Bold = False
Worksheets("RECAP_SEM").Range("A3").Select
colrecap = 1
Do Until IsEmpty(ActiveCell) = True
colrecap = colrecap + 1
ActiveCell.Offset(0, 1).Activate
Loop
If colrecap > nbinforecap + nbsem Then
Columns(nbinforecap + 1).Delete
colrecap = colrecap - 1
End If
Cells(3, colrecap).Value = ann.Value & "-" & sem.Value
Worksheets("RECAP_SANS_TEMPS").Activate
Worksheets("RECAP_SANS_TEMPS").Range("A3").Select
colrecstps = 1
Do Until IsEmpty(ActiveCell) = True
colrecstps = colrecstps + 1
ActiveCell.Offset(0, 1).Activate
Loop
If colrecstps > nbinforecstps + nbsem Then
Columns(nbinforecstps + 1).Delete
colrecstps = colrecstps - 1
End If
type_tps(0) = Trim("1.PREPARATION")
type_tps(1) = Trim("2.REALISATION")
type_tps(2) = Trim("3.CONTROLE")
type_tps(3) = Trim("4.NON AFFECTES")
Worksheets("RECAP_NON_AFF").Activate
Worksheets("RECAP_NON_AFF").Cells.Font.ColorIndex = 1
Worksheets("RECAP_NON_AFF").Cells.Font.Bold = False
Worksheets("RECAP_NON_AFF").Range("A3").Select
colnonaff = 1
Do Until IsEmpty(ActiveCell) = True
colnonaff = colnonaff + 1
ActiveCell.Offset(0, 1).Activate
Loop
If colnonaff > nbinfononaff + nbsem Then
Columns(nbinfononaff + 1).Delete
colnonaff = colnonaff - 1
End If
dpt_traite = ""
rsRecords.Open " select r.id_resource, r.name, d.name as departement from topmes.resources r inner join toppdm.resource_tree_item rt on r.id_resource = rt.id_resource inner join topsys.department d on rt.id_parent_origin = d.id_department where r.Type = 1 and upper(r.name) not like '%DISPO%' and d.id_department not in (361,1181,1421,1422)", conn, adOpenForwardOnly, adLockReadOnly
If conn.State = adStateOpen Then
rsRecords.MoveFirst
While Not rsRecords.EOF
a_traiter = True
nouvel_op = True
aucun_badgage = False
nom_prenom = Trim(UCase(rsRecords.Fields("name").Value))
posetoile = InStr(rsRecords.Fields("name").Value, "*")
nom_prenom = Replace(nom_prenom, "*", "")
vide = InStr(nom_prenom, " ")
If vide <> 0 Then
prenom = Left(nom_prenom, vide - 1)
nom = LTrim(Mid(nom_prenom, vide + 1))
nom_prenom = nom & " " & prenom
Else
nom_prenom = LTrim(nom_prenom)
End If
With Worksheets("INDIV")
Set rfound = .Range("B4:B" & nb_lig).Find(nom_prenom, LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Set rfound = Nothing
If posetoile > 0 And Left(.Range("A" & lalig).Value, 5) = "zzzz " Then
a_traiter = False
Else
nouvel_op = False
End If
End If
End With
If a_traiter Then
id_res = rsRecords.Fields("id_resource").Value
Set rsRecord_badg = conn.Execute("select w.id_wip from topmes.wip w where nvl(w.id_labor_resource,0) = " & id_res & " and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "'")
If rsRecord_badg.EOF Then
aucun_badgage = True
If posetoile <> 0 And nouvel_op Then
a_traiter = False
End If
Else
Set rsRecord_badg = conn.Execute("select w.id_labor_resource, sum(nvl(w.setup_time_hc,0)) as tps_prepa, sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl, sum(nvl(w.work_time_hc,0)) as tps_real from topmes.wip w where nvl(w.id_labor_resource,0) = " & id_res & " and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by w.id_labor_resource")
If Not rsRecord_badg.EOF Then
tps_prepa = rsRecord_badg("tps_prepa").Value
tps_real = rsRecord_badg("tps_real").Value
tps_ctrl = rsRecord_badg("tps_ctrl").Value
nb_heure = tps_prepa + tps_real + tps_ctrl
End If
End If
End If
If a_traiter Then
If nouvel_op Then
nb_lig = nb_lig + 1
lalig = nb_lig
End If
dpt_lu = rsRecords.Fields("departement").Value
With Worksheets("INDIV")
.Range("A" & lalig).Value = dpt_lu
.Range("B" & lalig).Value = nom_prenom
End With
Worksheets("INDIV").Activate
If aucun_badgage Then
If posetoile = 0 Then
Cells(lalig, col).Value = 0
Else
Cells(lalig, col).Value = ""
End If
Else
Cells(lalig, col).Value = nb_heure
End If
rsRecord_badg2.Open "select upper(rp.name) as name, sum(nvl(w.setup_time_hc,0)) as tps_prepa, sum(nvl(w.work_time_hc,0)) as tps_real, sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl " _
& " from topmes.wip w inner join toppdm.resources r on w.id_labor_resource = r.id_resource inner join toppdm.resources rp on w.id_resource = rp.id_resource where nvl(w.id_downtime_code,0) = 0 and nvl(w.id_labor_resource,0) = " & id_res & " and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by rp.name", conn, adOpenForwardOnly, adLockReadOnly
If conn.State = adStateOpen Then
If Not rsRecord_badg2.EOF Then
' Lecture du premier enregistrement
rsRecord_badg2.MoveFirst
While Not rsRecord_badg2.EOF
tps_prepa = rsRecord_badg2("tps_prepa").Value
tps_real = rsRecord_badg2("tps_real").Value
tps_ctrl = rsRecord_badg2("tps_ctrl").Value
poste = Trim(rsRecord_badg2("name").Value)
If tps_prepa <> 0 Then
trouve = False
i = 3
Do Until trouve Or i > nb_lig_recap
If Worksheets("RECAP_SEM").Range("B" & i) = nom_prenom And Worksheets("RECAP_SEM").Range("C" & i) = poste And Worksheets("RECAP_SEM").Range("D" & i) = type_tps(0) Then
trouve = True
End If
i = i + 1
Loop
If trouve Then
i = i - 1
Else
nb_lig_recap = nb_lig_recap + 1
With Worksheets("RECAP_SEM")
.Range("A" & i) = dpt_lu
.Range("B" & i) = nom_prenom
.Range("C" & i) = poste
.Range("D" & i) = type_tps(0)
End With
End If
Worksheets("RECAP_SEM").Activate
Cells(i, colrecap).Value = tps_prepa
End If
If tps_real <> 0 Or (tps_prepa = 0 And tps_real = 0 And tps_ctrl = 0) Then
trouve = False
i = 3
Do Until trouve Or i > nb_lig_recap
If Worksheets("RECAP_SEM").Range("B" & i) = nom_prenom And Worksheets("RECAP_SEM").Range("C" & i) = poste And Worksheets("RECAP_SEM").Range("D" & i) = type_tps(1) Then
trouve = True
End If
i = i + 1
Loop
If trouve Then
i = i - 1
Else
nb_lig_recap = nb_lig_recap + 1
With Worksheets("RECAP_SEM")
.Range("A" & i) = dpt_lu
.Range("B" & i) = nom_prenom
.Range("C" & i) = poste
.Range("D" & i) = type_tps(1)
End With
End If
Worksheets("RECAP_SEM").Activate
Cells(i, colrecap).Value = tps_real
End If
If tps_ctrl <> 0 Then
trouve = False
i = 3
Do Until trouve Or i > nb_lig_recap
If Worksheets("RECAP_SEM").Range("B" & i) = nom_prenom And Worksheets("RECAP_SEM").Range("C" & i) = poste And Worksheets("RECAP_SEM").Range("D" & i) = type_tps(2) Then
trouve = True
End If
i = i + 1
Loop
If trouve Then
i = i - 1
Else
nb_lig_recap = nb_lig_recap + 1
With Worksheets("RECAP_SEM")
.Range("A" & i) = dpt_lu
.Range("B" & i) = nom_prenom
.Range("C" & i) = poste
.Range("D" & i) = type_tps(2)
End With
End If
Worksheets("RECAP_SEM").Activate
Cells(i, colrecap).Value = tps_ctrl
End If
rsRecord_badg2.MoveNext
Wend
End If
End If
rsRecord_badg2.Close
Set rsRecord_badg2 = Nothing
Set rsRecord_badg = conn.Execute("select tmp.tps_prepa, tmp.tps_ctrl, tmp.tps_real, upper(rd.description) as description from (select w.id_labor_resource, nvl(w.id_downtime_code,0) as id_downtime_code, sum(nvl(w.setup_time_hc,0)) as tps_prepa, " _
& " sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl, sum(nvl(w.work_time_hc, 0)) As tps_real from topmes.wip w where nvl(w.id_downtime_code, 0) <> 0 and nvl(w.id_labor_resource,0) = " & id_res & "" _
& " and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by w.id_labor_resource, id_downtime_code) tmp inner join toppdm.resource_downtime_code rd " _
& " on tmp.id_downtime_code = rd.id_downtime_code")
If Not rsRecord_badg.EOF Then
tps_real = rsRecord_badg.Fields("tps_prepa").Value + rsRecord_badg.Fields("tps_real").Value + rsRecord_badg.Fields("tps_ctrl").Value
ressource = rsRecord_badg.Fields("description")
If tps_real <> 0 Then
trouve = False
i = 3
Do Until trouve Or i > nb_lig_recap
If Worksheets("RECAP_SEM").Range("B" & i).Value = nom_prenom And Worksheets("RECAP_SEM").Range("C" & i).Value = ressource And Worksheets("RECAP_SEM").Range("D" & i).Value = type_tps(3) Then
trouve = True
End If
i = i + 1
Loop
If trouve Then
i = i - 1
Else
nb_lig_recap = nb_lig_recap + 1
With Worksheets("RECAP_SEM")
.Range("A" & i) = dpt_lu
.Range("B" & i) = nom_prenom
.Range("C" & i) = ressource
.Range("C" & i).Font.ColorIndex = 2
.Range("D" & i) = type_tps(3)
End With
End If
Worksheets("RECAP_SEM").Activate
Cells(i, colrecap).Value = tps_real
End If
End If
rsRecord_badg2.Open "select upper(rp.description) as name, sum(nvl(w.setup_time_hc,0)) as tps_prepa, sum(nvl(w.work_time_hc,0)) as tps_real, sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl " _
& " from topmes.wip w inner join toppdm.resource_downtime_code rp on nvl(w.id_downtime_code,0) = rp.id_downtime_code where nvl(w.id_labor_resource,0) = " & id_res & " and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by rp.description", conn, adOpenForwardOnly, adLockReadOnly
If conn.State = adStateOpen Then
If Not rsRecord_badg2.EOF Then
rsRecord_badg2.MoveFirst
While Not rsRecord_badg2.EOF
tps_prepa = rsRecord_badg2("tps_prepa").Value
tps_real = rsRecord_badg2("tps_real").Value
tps_ctrl = rsRecord_badg2("tps_ctrl").Value
poste = rsRecord_badg2("name").Value
tps_total = tps_prepa + tps_real + tps_ctrl
' Si le temps total est différent de 0
If tps_total <> 0 Then
trouve = False
i = 3
Do Until trouve Or i > nb_lig_non_aff
If Worksheets("RECAP_NON_AFF").Range("B" & i) = nom_prenom And Worksheets("RECAP_NON_AFF").Range("C" & i) = poste Then
trouve = True
End If
i = i + 1
Loop
If trouve Then
i = i - 1
Else
nb_lig_non_aff = nb_lig_non_aff + 1
With Worksheets("RECAP_NON_AFF")
.Range("A" & i) = dpt_lu
.Range("B" & i) = nom_prenom
.Range("C" & i) = poste
End With
End If
Worksheets("RECAP_NON_AFF").Activate
Cells(i, colnonaff).Value = tps_total
End If
rsRecord_badg2.MoveNext
Wend
End If
End If
rsRecord_badg2.Close
Set rsRecord_badg2 = Nothing
rsRecord_badg2.Open "select upper(rp.description) as name, sum(nvl(w.setup_time_hc,0)) as tps_prepa, sum(nvl(w.work_time_hc,0)) as tps_real, sum(nvl(w.ctrl_time_hc,0)) as tps_ctrl " _
& " from topmes.wip w inner join toppdm.resource_downtime_code rp on nvl(w.id_downtime_code,0) = rp.id_downtime_code where nvl(w.id_labor_resource,0) = " & id_res & " and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' group by rp.description", conn, adOpenForwardOnly, adLockReadOnly
If conn.State = adStateOpen Then
If Not rsRecord_badg2.EOF Then
rsRecord_badg2.MoveFirst
While Not rsRecord_badg2.EOF
tps_prepa = rsRecord_badg2("tps_prepa").Value
tps_real = rsRecord_badg2("tps_real").Value
tps_ctrl = rsRecord_badg2("tps_ctrl").Value
poste = rsRecord_badg2("name").Value
tps_total = tps_prepa + tps_real + tps_ctrl
' Si le temps total est différent de 0
If tps_total <> 0 Then
trouve = False
i = 3
Do Until trouve Or i > nb_lig_non_aff
If Worksheets("RECAP_NON_AFF").Range("B" & i) = nom_prenom And Worksheets("RECAP_NON_AFF").Range("C" & i) = poste Then
trouve = True
End If
i = i + 1
Loop
If trouve Then
i = i - 1
Else
nb_lig_non_aff = nb_lig_non_aff + 1
With Worksheets("RECAP_NON_AFF")
.Range("A" & i) = dpt_lu
.Range("B" & i) = nom_prenom
.Range("C" & i) = poste
End With
End If
Worksheets("RECAP_NON_AFF").Activate
Cells(i, colnonaff).Value = tps_total
End If
rsRecord_badg2.MoveNext
Wend
End If
End If
rsRecord_badg2.Close
Set rsRecord_badg2 = Nothing
If dpt_lu <> dpt_traite Then
Set rsRecord_badg = conn.Execute("select d.name, sum(nvl(qty_completed,0)) as qte_travaillee from topmes.wip w inner join topmes.resources r on w.id_labor_resource = r.id_resource inner join toppdm.resource_tree_item rt " _
& "on r.id_resource = rt.id_resource inner join topsys.department d on rt.id_parent_origin = d.id_department where d.name = '" & dpt_lu & "' and TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "' and nvl(w.setup_time_hc,0) = 0 " _
& " and nvl(w.work_time_hc,0) = 0 and nvl(w.ctrl_time_hc,0) = 0 group by d.name")
If Not rsRecord_badg.EOF Then
qte_travaillee = rsRecord_badg.Fields("qte_travaillee").Value
If qte_travaillee <> 0 Then
With Worksheets("RECAP_SANS_TEMPS")
Set rfound = .Range("A4:A" & nb_lig_recap_stps).Find(dpt_lu, LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Set rfound = Nothing
Else
nb_lig_recap_stps = nb_lig_recap_stps + 1
lalig = nb_lig_recap_stps
End If
End With
Worksheets("RECAP_SANS_TEMPS").Activate
Cells(lalig, 1) = dpt_lu
Cells(lalig, colrecstps).Value = qte_travaillee
End If
End If
dpt_traite = dpt_lu
End If
End If
rsRecords.MoveNext
Wend
rsRecords.Close
Set rsRecords = Nothing
End If
nb_lig_stps = Worksheets("QTE_SANS_TEMPS").Cells(Application.Rows.Count, 1).End(xlUp).Row
rsRecords.Open "select case " _
& " when r.id_resource in (4185, 4184, 2428, 2429,2430,2464) then 'DPT_DEBIT' " _
& " when r.id_resource in (3901,2602,2764,4641) then 'DPT_CTRL_EXPEDITION' " _
& " when r.id_resource in (3621,3821,4121,4281,4961,3321,3322,3581,2426,2460,2461,2462,3801,5021,2468,4781,5341) then 'DPT_FINITION' " _
& " when r.id_resource in (3881,2463,2469) then 'DPT_QUALITE' " _
& " when r.id_resource in (3181,2901,2902,3861,4161,4162,2621,2622,2623,3121,2424,2438,2458,2459,2466,2425,2467,2761,2763,5321) then 'DPT_SOUDURE' " _
& " when r.id_resource in (5041,3241,3981,3982,4202,4241,2431,2432,2433,2434,2435,2436,2437,2439,2441) then 'DPT_TOLERIE' " _
& " when r.id_resource in (4201,4581,2440,2442,2444,2445,2446,2447,2448,2449,2450,2451,2452,2453,2454,2455,2456,2457,2465) then 'DPT_USINAGE' " _
& " when r.id_resource in (3083,4221) then 'DPT_GRENAILLEUSE' end as DEPARTEMENT, r.name as ressource, tmp.qte_travaillee from " _
& " (select nvl(w.id_resource,0) as id_resource, sum(nvl(w.qty_completed, 0)) As qte_travaillee from topmes.wip w where TO_CHAR(w.start_at_date,'IW') = '" & nosem & "' and TO_CHAR(w.start_at_date,'YYYY') = '" & annee & "'" _
& " and nvl(w.work_time_hc,0) = 0 and nvl(w.ctrl_time_hc,0) = 0 and nvl(w.id_resource,0) <> 0 group by nvl(w.id_resource,0)) tmp inner join toppdm.resources r on r.id_resource = tmp.id_resource left outer join toppdm.resource_tree_item rt " _
& " on r.id_resource = rt.id_resource left outer join topsys.department d on rt.id_parent_origin = d.id_department ", conn, adOpenForwardOnly, adLockReadOnly
If conn.State = adStateOpen And Not rsRecords.EOF Then
rsRecords.MoveFirst
While Not rsRecords.EOF
ressource = rsRecords.Fields("ressource").Value
With Worksheets("QTE_SANS_TEMPS")
Set rfound = .Range("B4:B" & nb_lig_stps).Find(ressource, LookIn:=xlValues, lookat:=xlWhole)
If Not rfound Is Nothing Then
lalig = rfound.Row
Set rfound = Nothing
Else
nb_lig_stps = nb_lig_stps + 1
lalig = nb_lig_stps
End If
.Range("A" & lalig).Value = rsRecords.Fields("DEPARTEMENT").Value
.Range("B" & lalig).Value = ressource
End With
Worksheets("QTE_SANS_TEMPS").Activate
Cells(lalig, colstps).Value = rsRecords.Fields("qte_travaillee").Value + Cells(lalig, colstps).Value
rsRecords.MoveNext
Wend
rsRecords.Close
Set rsRecords = Nothing
End If
conn.Close
Set conn = Nothing
If nb_lig_stps > num_lig_dep Then
Worksheets("QTE_SANS_TEMPS").Range("B3").Select
colstps = colstps + 1
For i = Cells(3, 1).CurrentRegion.Rows.Count To 3 Step -1
If colstps - 1 - nbinfostps > dureecons Then
Cells(i, colstps).FormulaR1C1Local = "=NB.VIDE(L" & i & "C" & nbinfostps + 1 & " :L" & i & "C(-1))"
If Cells(i, colstps).Value > nbinfostps - 1 Then
Cells(i, 1).EntireRow.Delete
Else
Cells(i, colstps).Value = ""
End If
End If
Next
colstps = colstps - 1
For j = nbinfostps + 1 To colstps
For i = 4 To nb_lig_stps
If Cells(i, j).Value = "" Then
Cells(i, j).Value = 0
End If
Next
Next
End If
With Sheets("QTE_SANS_TEMPS")
.Range(.Cells(3, 1), .Cells(nb_lig_stps, colstps)).Sort Key1:=.Range("A3"), Order1:=xlAscending, key2:=.Range("B3"), Order2:=xlAscending, Header:=xlYes
End With
With Worksheets("QTE_SANS_TEMPS")
.Range("A1").Value = "Date d'extraction : " & date_jour
'.Range(.Cells(4, nbinfostps + 1), .Cells(nb_lig_stps, colstps)).NumberFormat = "0.00"
With .Range(.Cells(1, 1), .Cells(nb_lig_stps, colstps)).Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
.Range(.Cells(1, 1), .Cells(nb_lig_stps, colstps)).Columns.AutoFit
.Range(.Cells(1, 1), .Cells(nb_lig_stps, colstps)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 1), .Cells(nb_lig_stps, colstps)).VerticalAlignment = xlBottom
End With
Worksheets("RECAP_SANS_TEMPS").Cells.Clear
Worksheets("RECAP_SANS_TEMPS").Cells.Font.Bold = False
With Worksheets("QTE_SANS_TEMPS")
.Range(.Cells(1, 1), .Cells(3, colstps)).Copy
End With
Worksheets("QTE_SANS_TEMPS").Paste Destination:=Worksheets("RECAP_SANS_TEMPS").Range("A1")
Worksheets("RECAP_SANS_TEMPS").Activate
Columns("B:B").Delete Shift:=xlToLeft
nbcol = colstps - nbinfostps
fin_trt = False
Worksheets("QTE_SANS_TEMPS").Activate
i = 4
ligsec = 4
dpt_lu = Cells(i, 1).Value
If dpt_lu = "" Then
fin_trt = True
End If
Do Until fin_trt
Worksheets("QTE_SANS_TEMPS").Activate
Erase tableau
ReDim tableau(colstps - 1 - nbinfostps)
dpt_traite = dpt_lu
Do Until fin_trt Or dpt_lu <> dpt_traite
k = 0
For j = nbinfostps + 1 To colstps
tableau(k) = tableau(k) + Cells(i, j).Value
k = k + 1
Next j
i = i + 1
dpt_lu = Cells(i, 1).Value
If dpt_lu = "" Then
fin_trt = True
End If
Loop
Worksheets("RECAP_SANS_TEMPS").Activate
Cells(ligsec, 1) = dpt_traite
For j = 0 To UBound(tableau)
Cells(ligsec, j + 2) = tableau(j)
Next j
ligsec = ligsec + 1
Loop
Worksheets("RECAP_SANS_TEMPS").Activate
If ligsec > 4 Then
Cells(ligsec, 1).Value = lib
Cells(ligsec, 1).Font.Bold = True
For j = 2 To colstps - 1
Cells(ligsec, j).FormulaR1C1Local = "=SOMME(L4C" & j & ":L" & ligsec - 1 & "C" & j & ")"
Next
End If
nb_lig_recap_stps = Worksheets("RECAP_SANS_TEMPS").Range("A65536").End(xlUp).Row
With Worksheets("RECAP_SANS_TEMPS")
.Range("A1").Value = "Date d'extraction : " & date_jour ' Police 10 aerial
With .Range(.Cells(1, 1), .Cells(nb_lig_recap_stps, colrecstps)).Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
.Range(.Cells(1, 1), .Cells(nb_lig_recap_stps, colrecstps)).Columns.AutoFit
.Range(.Cells(1, 1), .Cells(nb_lig_recap_stps, colrecstps)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 1), .Cells(nb_lig_recap_stps, colrecstps)).VerticalAlignment = xlBottom
End With
Worksheets("RECAP_SEM").Activate
Worksheets("RECAP_SEM").Range("A3").Select
dercol = 1
While IsEmpty(ActiveCell) = False
dercol = dercol + 1
ActiveCell.Offset(0, 1).Activate
Wend
Worksheets("RECAP_SEM").Cells(Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row, colrecap)).ClearContents
nb_lig_recap = Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row
Worksheets("RECAP_SEM").Activate
coldeb = nbinforecap + 1
nb_col = dercol - coldeb
If nb_col > 4 Then
i = 4
fin_trt = False
If Cells(i, 1).Value = "" Then
fin_trt = True
End If
Do Until fin_trt
Cells(i, dercol).FormulaR1C1Local = "=NB.VIDE(L" & i & "C" & dercol - 6 & " :L" & i & "C" & dercol - 1 & ")"
If Cells(i, dercol).Value > 4 Then
Cells(i, 1).EntireRow.Delete
Else
i = i + 1
End If
If Cells(i, 1).Value = "" Then
fin_trt = True
End If
Loop
Columns(dercol).Delete
nb_lig_recap = Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row
End If
nb_lig_recap = Worksheets("RECAP_SEM").Range("A65536").End(xlUp).Row
If nb_lig_recap > 3 Then
Worksheets("RECAP_SEM").Range("A:A").Insert Shift:=xlToRight
Worksheets("RECAP_SEM").Range("A3").Value = "Tri"
Worksheets("RECAP_SEM").Range("A4:A" & nb_lig_recap).FormulaR1C1 = "=RC[4]&RC[3]&RC[2]&RC[1]"
Worksheets("RECAP_SEM").Range("A3:A" & nb_lig_recap).Sort Key1:=.Range("A3"), Order1:=xlAscending, Header:=xlYes
Columns("A").Delete Shift:=xlToLeft
End If
With Worksheets("RECAP_SEM")
.Range("A1").Value = "Date d'extraction : " & date_jour
.Range(.Cells(4, 5), .Cells(nb_lig_recap, dercol)).NumberFormat = "0.00"
With .Range(.Cells(1, 1), .Cells(nb_lig_recap, dercol)).Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
.Range(.Cells(1, 1), .Cells(nb_lig_recap, dercol)).Columns.AutoFit
.Range(.Cells(1, 1), .Cells(nb_lig_recap, dercol)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 1), .Cells(nb_lig_recap, dercol)).VerticalAlignment = xlBottom
End With
If nb_lig_non_aff > num_lig_dep Then
Worksheets("TRI_NON_AFF").Cells.Clear
Worksheets("RECAP_NON_AFF").Range(Worksheets("RECAP_NON_AFF").Cells(4, 1), Worksheets("RECAP_NON_AFF").Cells(Worksheets("RECAP_NON_AFF").Range("A65536").End(xlUp).Row, colrecap)).Copy
Worksheets("TRI_NON_AFF").Paste Destination:=Worksheets("TRI_NON_AFF").Range("A1")
Worksheets("RECAP_NON_AFF").Activate
Worksheets("RECAP_NON_AFF").Range("A3").Select
dercol = 1
While IsEmpty(ActiveCell) = False
dercol = dercol + 1
ActiveCell.Offset(0, 1).Activate
Wend
dercol = dercol + 1
Worksheets("TRI_NON_AFF").Activate
Worksheets("TRI_NON_AFF").Range("A1").Select
For i = Cells(1, 1).CurrentRegion.Rows.Count To 1 Step -1
If dercol - 1 - nbinfononaff > dureecons Then
Cells(i, dercol).FormulaR1C1Local = "=NB.VIDE(L" & i & "C" & nbinfononaff + 1 & " :L" & i & "C(-1))"
If CInt(Cells(i, dercol).Value) >= dureecons And Left(Cells(i, 1).Value, 4) <> "zzzz" Then
Cells(i, 1).Value = "zzzz " & Cells(i, 1).Value
Worksheets("TRI_NON_AFF").Range(Cells(i, 1), Cells(i, dercol)).Font.ColorIndex = 10
Cells(i, dercol).Value = ""
End If
If Cells(i, dercol).Value > nbinfononaff - 1 Then
Cells(i, 1).EntireRow.Delete
End If
End If
Next
' Tri de la feuille de tri des activités non affectées par opérateur et par poste
With Sheets("TRI_NON_AFF")
.Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, dercol)).Sort Key1:=.Range("A1"), Order1:=xlAscending, key2:=.Range("B1"), Order2:=xlAscending, Key3:=.Range("C1"), Order3:=xlAscending, Header:=xlNo
End With
' Effacement du tableau contenu dans la feuille de RECAP_NON_AFF
Worksheets("RECAP_NON_AFF").Range(Worksheets("RECAP_NON_AFF").Cells(4, 1), Worksheets("RECAP_NON_AFF").Cells(Worksheets("RECAP_NON_AFF").Range("A65536").End(xlUp).Row, colrecap)).ClearContents
' Copie de la feuille TRIRECAP dans la feuille RECAP_SEM
With Worksheets("TRI_NON_AFF")
.Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, dercol - 1)).Copy
End With
Worksheets("RECAP_NON_AFF").Paste Destination:=Worksheets("RECAP_NON_AFF").Range("A4")
nb_lig_non_aff = Worksheets("RECAP_NON_AFF").Range("A65536").End(xlUp).Row
dercol = dercol - 1
' Ajout de la semaine dans la dernière colonne de la ligne des entêtes
Worksheets("RECAP_NON_AFF").Activate
Cells(3, dercol).Value = annee_sem
' Mise en forme de la feuille RECAP_NON_AFF
With Worksheets("RECAP_NON_AFF")
.Range("A1").Value = "Date d'extraction : " & date_jour
.Range(.Cells(4, 5), .Cells(nb_lig_non_aff, dercol)).NumberFormat = "0.00"
' Police 10 aerial
With .Range(.Cells(1, 1), .Cells(nb_lig_non_aff, dercol)).Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
.Range(.Cells(1, 1), .Cells(nb_lig_non_aff, col)).Columns.AutoFit
.Range(.Cells(1, 1), .Cells(nb_lig_non_aff, col)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 1), .Cells(nb_lig_non_aff, col)).VerticalAlignment = xlBottom
End With
' fin si j'ai des données dans la feuille RECAP_NON_AFF
End If
' Je vide la feuille de tri
Worksheets("TRI").Cells.Clear
' Je copie le tableau dans la feuille de tri
Worksheets("INDIV").Range(Worksheets("INDIV").Cells(4, 1), Worksheets("INDIV").Cells(Worksheets("INDIV").Range("A65536").End(xlUp).Row, col)).Copy
Worksheets("TRI").Paste Destination:=Worksheets("TRI").Range("A1")
Worksheets("TRI").Activate
Worksheets("TRI").Range("A1").Select
dercol = 1
While IsEmpty(ActiveCell) = False
dercol = dercol + 1
ActiveCell.Offset(0, 1).Activate
Wend
' Si le nombre de colonnes avec valeurs est inférieur à la durée de l'historisation
If dercol - 1 - nbinfo > dureecons Then
' On supprime la ligne si le nombre de lignes vides est > 50
If Cells(i, dercol).Value > nbinfo - 1 Then
Cells(i, 1).EntireRow.Delete
End If
End If
' Tri de la feuille de tri par département puis nom et prénom
With Sheets("TRI")
.Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, dercol)).Sort Key1:=.Range("A1"), Order1:=xlAscending, key2:=.Range("B1"), Order2:=xlAscending, Header:=xlNo
End With
' Effacement du tableau contenu dans la feuille de INDIV
Worksheets("INDIV").Range(Worksheets("INDIV").Cells(4, 1), Worksheets("INDIV").Cells(Worksheets("INDIV").Range("A65536").End(xlUp).Row, col)).ClearContents
' Copie de la feuille TRI dans la feuille INDIV
With Worksheets("TRI")
.Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, dercol - 1)).Copy
End With
Worksheets("INDIV").Paste Destination:=Worksheets("INDIV").Range("A4")
' Initialisation de la feuille de SECTEUR
Worksheets("SECTEUR").Cells.Clear
Worksheets("SECTEUR").Cells.Font.Bold = False
' Copie des entêtes de la feuille INDIV
With Worksheets("INDIV")
.Range(.Cells(1, 1), .Cells(3, dercol - 1)).Copy
End With
Worksheets("INDIV").Paste Destination:=Worksheets("SECTEUR").Range("A1")
Worksheets("SECTEUR").Activate
' Supression de la colonne opérateur
Columns("B:B").Delete Shift:=xlToLeft
' Balayage des lignes de la feuille "SECTEUR" et totalisation par département différent de 'zzzz '
' Détermination du nombre de colonnes avec des données dans le tableau "SECTEUR" ( Département + données)
nbcol = dercol - 1 - nbinfo
fin_trt = False
Worksheets("INDIV").Activate
' Positionnement sur la 4ème ligne
i = 4
ligsec = 4
dpt_lu = Cells(i, 1).Value
' Si le département lu n'est pas renseigné ou qu'il commence par 'zz' alors on est en fin de traitement
If dpt_lu = "" Or Left(dpt_lu, 5) = "zzzz " Then
fin_trt = True
End If
' on balaye tout le tableau jusqu'à obtenir le premier département avec 'zz' ou le département contient une cellule vide
Do Until fin_trt
Worksheets("INDIV").Activate
' Réinitialisation du tableau
Erase tableau
' Le tableau contient le nom du département + la totalisation
ReDim tableau(dercol - 2 - nbinfo)
' Alimentation du département dans le tableau
dpt_traite = dpt_lu
' on traite le département jusqu'à rupture ou fin de tableau
Do Until fin_trt Or dpt_lu <> dpt_traite
k = 0
' Alimentation du tableau
' On part du nombre d'information
For j = nbinfo + 1 To dercol - 1
tableau(k) = tableau(k) + Cells(i, j).Value
k = k + 1
Next j
i = i + 1
dpt_lu = Cells(i, 1).Value
' Si le département lu n'est pas renseigné ou qu'il commence par 'zz' alors on est en fin de traitement
If dpt_lu = "" Or Left(dpt_lu, 5) = "zzzz " Then
fin_trt = True
End If
Loop
Worksheets("SECTEUR").Activate
' Bascule du tableau dans le classeur du secteur
Cells(ligsec, 1) = dpt_traite
For j = 0 To UBound(tableau)
Cells(ligsec, j + 2) = tableau(j)
Next j
' Ajout d'une ligne sur le tableau indiv
ligsec = ligsec + 1
Loop
Worksheets("SECTEUR").Activate
' Ajout du total général
If ligsec > 4 Then
Cells(ligsec, 1).Value = "Total général"
Cells(ligsec, 1).Font.Bold = True
For j = 2 To dercol - nbinfo
Cells(ligsec, j).FormulaR1C1Local = "=SOMME(L4C" & j & ":L" & ligsec - 1 & "C" & j & ")"
Next
End If
' Mise en forme de la feuille SECTEUR
With Worksheets("SECTEUR")
.Range("A1").Value = "Date d'extraction : " & date_jour
.Range(.Cells(3, 1), .Cells(ligsec, col)).NumberFormat = "0.00"
' Police 10 aerial
With .Range(.Cells(1, 1), .Cells(ligsec, col)).Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
.Range(.Cells(1, 1), .Cells(ligsec, col)).Columns.AutoFit
End With
' Ajout des indicateurs en bas de la feuille INDIV
Worksheets("INDIV").Activate
' Récupération du nombre total de lignes dans la feuille INDIV
nb_lig = Worksheets("INDIV").Range("A65536").End(xlUp).Row
lig = nb_lig + 1
' Mise en place en colonne des indicateurs par semaine :
' - moyennes,
' - écart-type,
' - écart-type rapporté à la moyenne.
'
' Wiki : La notion d'écart type élevé n'a aucun sens dans l'absolu.
' Elle ne traduit une forte dispersion que si on rend la valeur adimensionnelle en la divisant par la moyenne
Worksheets("INDIV").Range("A3").Select
' Détermination de la première colonne vide
col = 1
While IsEmpty(ActiveCell) = False
col = col + 1
ActiveCell.Offset(0, 1).Activate
Wend
col = col - 1
Cells(lig, 1).Value = indicateur(0)
Cells(lig, 1).Font.Bold = True
Cells(lig + 1, 1).Value = indicateur(1)
Cells(lig + 1, 1).Font.Bold = True
Cells(lig + 2, 1).Value = indicateur(2)
Cells(lig + 2, 1).Font.Bold = True
Cells(lig + 3, 1).Value = indicateur(3)
Cells(lig + 3, 1).Font.Bold = True
Cells(lig + 4, 1).Value = indicateur(4)
Cells(lig + 4, 1).Font.Bold = True
For i = 3 To col Step 1
' Moyenne
Cells(lig, i).FormulaR1C1Local = "=MOYENNE(L4C" & i & ":L" & nb_lig & "C" & i & ")"
' Ecart-type
Cells(lig + 1, i).FormulaR1C1Local = "=ECARTYPEP(L4C" & i & ":L" & nb_lig & "C" & i & ")"
' Ecart-type rapporté à la moyenne
Cells(lig + 2, i).Value = Cells(lig + 1, i).Value / Cells(lig, i).Value
' Nombre de personnes présentes n'ayant pas badgées (cellules contenant 0)
Cells(lig + 3, i).FormulaR1C1Local = "=NB.SI(L4C" & i & ":L" & nb_lig & "C" & i & ";0)"
' Nombre de cellules différentes de 0
Cells(lig + 5, i).FormulaR1C1Local = "=NB.SI(L4C" & i & ":L" & nb_lig & "C" & i & ";""<>0"")"
' Nombres de personnes ayant badgées (cellules différentes de 0 - nb de cellules vides)
' Cells(lig + 5, i).FormulaR1C1Local = "=NB.SI(L4C" & i & ":L" & nb_lig & "C" & i & ";'<>0')"
' Nombre de personnes absentes
Cells(lig + 6, i).FormulaR1C1Local = "=NB.VIDE(L4C" & i & ":L" & nb_lig & "C" & i & ")"
' Renseignement du nombre de personnes ayant badgées
Cells(lig + 4, i).Value = Cells(lig + 5, i).Value - Cells(lig + 6, i).Value
Cells(lig + 5, i).Value = ""
Cells(lig + 6, i).Value = ""
Next i
' Permet de désactiver le presse papier
Application.CutCopyMode = False
With Worksheets("INDIV")
With .Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, col)).Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
.Range("A1").Value = "Date d'extraction : " & date_jour
.Range(.Cells(3, 1), .Cells(.Range("A65536").End(xlUp).Row, col)).NumberFormat = "0.00"
' Les 2 dernières lignes de la feuille INDIV soivent être au format 0
.Range(.Cells(.Range("A65536").End(xlUp).Row - 1, 1), .Cells(.Range("A65536").End(xlUp).Row, col)).NumberFormat = "0"
.Range(.Cells(1, 1), .Cells(.Range("A65536").End(xlUp).Row, col)).Columns.AutoFit
End With
' Définition de la zone d'impression
MsgBox "Traitement terminé !"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Worksheets("SECTEUR").Activate
Worksheets("SECTEUR").Range("A1").Select
UserForm1.Hide
End Sub
' ---
' CALCUL DU 1ER JOUR D'UNE SEMAINE DONNEE
' ---
' La semaine est calculée "à la française".
' Remplacer vbMonday et vbFirstFourDays pour d'autres
' méthodes.
'
Function DateSemaineFR( _
ByVal intAnnee As Integer, _
Optional ByVal intSemaine As Integer = 1)
Dim dt As Date
' Trouver le 1er jour de la semaine 1 de l'année
' (pas forcément le 1/1/aaaa en France !)
dt = DateSerial(intAnnee, 1, 1)
While DatePart("ww", dt, vbMonday, vbFirstFourDays) <> 1
dt = dt + 1
Wend
' Calculer le 1er jour de la semaine demandée
dt = dt - DatePart("w", dt, vbMonday) + 1
dt = dt + 7 * (intSemaine - 1)
DateSemaineFR = dt
End Function
' ---
' CALCUL DU NO DE SEMAINE A PARTIR D'UNE DATE
' ---
Function nsem(ByVal wdate As Date)
' Variable utilisée pour récupérer le numéro de semaine
Dim Jan03 As Long
' N° de semaine (norme iso)
Dim nosem As Integer
' Récupération du numéro de semaine en cours
Jan03 = DateSerial(Year(wdate - Weekday(wdate - 1) + 4), 1, 3)
nosem = Int((wdate - Jan03 + Weekday(Jan03) + 5) / 7)
nsem = nosem
End Function
Private Sub UserForm_Activate()
Dim conn As New ADODB.Connection
Dim connString
Dim rsRecords As New ADODB.Recordset
' Récupération de la date du jour
Dim datejour, date_debut As Date
' Date du premier jour de la semaine
Dim datepremjour As Date
' Variable utilisée pour récupérer le numéro de semaine
Dim Jan03 As Long
' N° de semaine (norme iso)
Dim nosem, num_annee As Integer
connString = "DSN=TOP;Uid=TOPMAN01;Pwd=TOPMAN01"
conn.Open connString
' Récupération du numéro de semaine du jour
nosem = nsem(Date)
num_annee = Format(Now, "yyyy")
' Si la semaine actuelle est '01' alors la semaine précédente est la dernière de l'année précédente
If nosem = 1 Then
num_annee = num_annee - 1
nosem = 52
Else
nosem = nosem - 1
End If
' Récupération du premier jour de la semaine précédent la date du jour
datepremjour = DateSemaineFR(num_annee, nosem)
' Récupération de la semaine
' On regarde si le premier jour de la semaine précédente était dans des congés.
' Si tel était le cas, on prend la semaine précédent les congés
' Sinon on prend la semaine précédente
' On recherche si la semaine précédente correspondait à des congés
Set rsRecords = conn.Execute("select rb.date_start as date_debut from resource_calendar rc inner join resource_calendar_band rb on rb.id_resource_calendar = rc.id_resource_calendar where rc.reference = 'METAL 44' and nvl(rb.type,0) = 6 and rb.date_start <= '" & datepremjour - 7 & "' and rb.date_end >= '" & datepremjour & "'")
If Not rsRecords.EOF Then
' La semaine précédente correspondait à des congés, on récupére la 1ère semaine où nous n'étions pas en congés
date_debut = CDate(rsRecords.Fields("date_debut").Value) - 1
nosem = nsem(date_debut)
num_annee = Format(date_debut, "yyyy")
End If
rsRecords.Close
Set rsRecords = Nothing
sem.Value = nosem
ann.Value = num_annee
sem.SetFocus
End Sub