Il y a quelques temps je me suis fais aider sur ce forum pour gérer des temps de production dans mon entreprise …
J’ai un code VBA qui prends mes données et incrémente un tableau.
Je souhaiterais supprimer la ligne total mais je n’y arrive pas (quand je décoche la ligne du tableau puis j’active la macro, la ligne total revient) :
J’aimerais en :
1 le total des temps de la semaine
2 le temps recap des des différentes colonnes de « débit » à Summop (donc sans le temps 3 qui est du temps masqué)
Sub M_Recap_TPS()
Dim Sh, LO, Dernl, Arr0, Arr(1 To 1000, 0 To 20), Dict, s As String, bExists, Valeur As Double, t
Dim iOffset: iOffset = 6 'décalage pour la colonne "débit"
t = Timer
Set Dict = CreateObject("scripting.dictionary") 'dictionaire pour les OF-uniques
Dict.comparemode = vbTextCompare
Set LO = Range("Tableau2").ListObject 'le TS "TPS"
LO.Parent.Unprotect 'déprotéger feuille
If LO.ListRows.Count Then LO.DataBodyRange.Delete 'RAZ tableau
For Each Sh In ThisWorkbook.Worksheets 'boucler les feuilles
If Sh.Name Like ("##_S##") Then 'c'est une semaine
With Sh
Dernl = .UsedRange.Row + .UsedRange.Rows.Count - 1 'dernière ligne
Arr0 = .Range("A1").Resize(Dernl, 26).Value2 'lire contenu de la feuille
For i = 8 To UBound(Arr0) 'boucler à partir de la 8ième ligne jusqu'au dernier
If Len(Arr0(i, 4)) And StrComp(Arr0(i, 1), "TOTAL HEURES", 1) <> 0 Then 'OF connu et ne pas un "total"
s = Arr0(i, 4) & "|" & Left(Sh.Name, 2) 'le "OF"
bExists = Dict.exists(s) 'nouveau TF'
If bExists Then
R = Dict(s) 'numéro de ligne dans "Arr" pour ce "OF"
Else
R = Dict.Count + 1 'ligne assigné dans "Arr" pour ce "OF"
Dict(s) = R 'ajouter au dictionaire
Arr(R, 0) = Arr0(i, 4) 'premier élément, c'est cet "OF"
Arr(R, 1) = 2000 + Left(Sh.Name, 2) 'premier élément, c'est cet "OF"
End If
For j = 2 To Application.Min(UBound(Arr, 2), UBound(Arr0, 2) - iOffset - 1) 'boucler 2ième au dernier élément de sa ligne
Valeur = Arr0(i, j + iOffset) 'valeur dans la feuille
If Valeur <> 0 Then Arr(R, j) = Arr(R, j) + Valeur 'si valeur <>0, cumuler
Next
End If
Next
End With
End If
Next
With LO 'notre TS vide
If Dict.Count Then
.ShowTotals = False
.ListRows.Add.Range.Resize(Dict.Count, UBound(Arr, 2) + 1).Value2 = Arr 'coller contenu de Arr dans le TS
If Dict.Count > 1 Then
.ListRows(2).Range.Copy
.ListRows(1).Range.PasteSpecial xlFormats
End If
.Range.Sort .Range.Range("B1"), xlDescending, .Range.Range("A1"), , xlDescending, Header:=xlYes 'trier par les OFs ascendant
' .ShowTotals = True
.Range.EntireColumn.AutoFit
End If
.Parent.Protect
End With
bChangement = False
End Sub
Sub M_Recap_Heures()
Dim Sh, SH0, aWeekdays, i, c0 As Range, c As Range, c1 As Range, cMA
Dim iOffset: iOffset = 3
Set SH0 = Sheets("recap Heures")
With SH0
On Error Resume Next
.AutoFilter.Range.AutoFilter
On Error GoTo 0
.Rows(5).Resize(Rows.Count - 4).Delete
.Range("AA1:AB1").EntireColumn.Clear
End With
aWeekdays = Evaluate("text(column(offset(b1,,,,5)),""[$-fr-fr]dddd"")")
For Each Sh In ThisWorkbook.Worksheets 'boucler les feuilles
If Sh.Name Like ("##_S##") Then 'c'est une semaine
Set c1 = SH0.Columns("B").Find("*", After:=SH0.Range("B1"), searchdirection:=xlPrevious)
If c1 Is Nothing Then Set c = SH0.Range("b5") Else Set c = c1.Offset(iOffset)
With c.Resize(7, 22)
.Borders.LineStyle = xlContinuous
.BorderAround Weight:=xlMedium
.Resize(, 1).Merge
.Cells(1) = Sh.Name
With .Offset(7, 2).Resize(1, 19)
.FormulaR1C1 = "=sum(R[-7]C:R[-1]C)"
.Font.Bold = True
.Cells(1).FormulaR1C1 = "=sum(RC[1]:RC[19])"
.Cells(1).Font.Color = RGB(255, 0, 0)
.Cells(1).Font.Underline = xlUnderlineStyleDouble
End With
End With
With Sh
For i = 1 To UBound(aWeekdays)
On Error Resume Next
Set cMA = Sh.Range(aWeekdays(i)).MergeArea
On Error GoTo 0
If Not cMA Is Nothing Then
c.Cells(i, 2).Value2 = cMA.Value2
Set c0 = cMA.Cells(1, 2).Offset(cMA.Rows.Count)
c.Cells(i, 3).FormulaLocal = "='" & Sh.Name & "'!" & c0.Address(0, 0)
c.Cells(i, 4).FormulaLocal = "='" & Sh.Name & "'!" & c0.Offset(, 3).Address(0, 0)
c.Cells(i, 4).Copy
c.Cells(i, 4).Resize(, 19).PasteSpecial xlFormulas
End If
c.Cells(7, 3) = Application.Sum(c.Cells(1, 3).Resize(5))
c.Cells(7, 2) = "TOTAL " & c.Value
With c.Cells(7, 2).Resize(, 2).Font
.Bold = True
.Color = RGB(0, 176, 80)
End With
Next
End With
End If
Next
With SH0
Application.Goto .Range("B1"), 1
Range("E5").Select
ActiveWindow.FreezePanes = True
End With
End Sub
Lors que j’importe les donnée (SUM ALL) il me demande tjs si je veux supprimer une ligne ..
Chaque employé a un fichier SUM Vierge à son nom dans lequel je saisis les données et ensuite je les importe dans le fichier Pilotage.
Si vous ave le temps de regarder …
Merci
Je pense que le tableau croisé dynamique qui est dans listing je vais le sortir de là et le mettre ailleurs ..
dans PERFORMANCE j’ai besoin des données pour le pilotage de la performe dû à la norme ISO 9001
MACRO : Quand je lance la macro d’ouverture (OUVERTURE 2). çà lance la macro .._ALL_IN_ONE pour importer les données de chaque employé dans l’onglet SUM_ALL et la macro M_Recap_OF
BUG : Quand je lance le M_RECAP_OF y a plusieurs problèmes …
J’ai été obligé de créer des colonnes W à Z pour éviter que la macro me supprimer mes données de A à AD (initialement en W,X,Y et Z).
La macro me demande tjs si je veux supprimer une ligne .. est-ce que je peux supprimer ce message de la macro ?
Sub M_Recap_OF()
Dim Arr, aOut, i, j, Ligne, Colonne, Dict
Arr = Range("TBL_SUM_ALL_IN_ONE").ListObject.Range.Value2 'TS pour tous les salariés, entête et contenu
ReDim aOut(1 To UBound(Arr), 1 To 22)
Set Dict = CreateObject("scripting.dictionary")
Dict.comparemode = vbTextCompare
With Range("Recap_OF").ListObject 'TS Recap
aHead = .HeaderRowRange.Value2 'headers du TS Recap
For i = 2 To UBound(Arr) 'boucler données des salariés
If Len(Arr(i, 2)) > 0 Then 'OF connu
If Not Dict.exists(Arr(i, 2)) Then Dict(Arr(i, 2)) = Dict.Count + 1 'si OF est connu
Ligne = Dict(Arr(i, 2)) 'ligne dans aOut pour cet OF
For j = 5 To UBound(Arr, 2) - 1 'boucler les colonnes a partir du 5ième, sauf la somme
If Len(Arr(i, j)) > 0 Then 'il y a une valeur pour cet OF et colonne
Colonne = Application.IfError(Application.Match(Arr(1, j), aHead, 0), 0) - 4 'colonne dans aOut
If 1 <= Colonne And Colonne <= UBound(aOut, 2) Then
aOut(Ligne, Colonne) = aOut(Ligne, Colonne) + Arr(i, j) 'cumuler
Else
MsgBox "erreur colonne", vbCritical, Arr(1, j)
End If
End If
Next
End If
Next
.Parent.Unprotect
Application.DisplayAlerts = False
If .ListRows.Count Then .DataBodyRange.Delete 'RAZ TS
Application.DisplayAlerts = True
.ListRows.Add.Range.Resize(Dict.Count, 1).Value = Application.Transpose(Dict.keys) 'première colonne
.DataBodyRange.Cells(1, 5).Resize(Dict.Count, UBound(aOut, 2)).Value2 = aOut '5-ième a 22-ieme colonne
.Range.Sort .Range.Range("A1"), xlAscending, Header:=xlYes
.Parent.Protect
End With
End Sub
Il n’y a plus de message. Ca plante sur la ligne suivante parce que le dictionnaire est vide. Sais-tu pourquoi ?
