MikeBelgique
XLDnaute Occasionnel
Bonjour Forum,
Il y a 5ans Ninbihan m'avait apporté sa précieuse collaboration pour la création d'un programme dont j'utilisais à mon boulot dont l'entreprise fonctionnait sous excell 2003, or suite à la migration de 2003 vers 2010, malheureusement mon tableau ne fonctionne plus.
Voici le code vba :
Public Flag As Boolean
'Flag est une variable qui passe à vrai dès qu'une modif est faite dans BD voir macro évenementielle de BD
'Ensuite lorsque l'on active la feuille projection si cette variable est vrai alors on execute la macro ci dessous
'voir macro évenementielle de projection
Sub generelist()
With Sheets("Projection")
Dim Nbjour As Integer
Dim Cell As Range
'Suppresion des lignes sauf L4 pour garder les formules
If .Range("A4").End(xlDown).Row > 4 And .Range("A4").End(xlDown).Row < 65536 Then
.Range("A5:A" & .Range("A4").End(xlDown).Row).EntireRow.Delete (xlshift)
End If
'Effacement du contenu de la ligne 4
.Range("A4:AH4").ClearContents
'Définition de la première ligne
i = 4
'Boucle balayant toutes les valeurs de BASE DONNEE AGENT
For Each Cell In Sheets("BASE DONNEE AGENT").Range("A2").CurrentRegion
If Not IsEmpty(Cell) And Cell.Row <> 2 Then
.Cells(i, 1) = Sheets("BASE DONNEE AGENT").Cells(2, Cell.Column)
If Right(Cell, 3) = "38H" Or Right(Cell, 3) = "38h" Then 'Ce if détermine la présence de 38 H en fin de nom
.Cells(i, 3) = "38H"
.Cells(i, 2) = Mid(Cell, 1, Len(Cell) - 4)
Else
.Cells(i, 2) = Cell
End If
'Copie du format de La ligne 4
.Range("A4:AH4").Copy
.Range("A" & i).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Copie de le formule calcul voir dans insertion nom
Range("D" & i & ":AH" & i).Formula = "=calcul"
Application.CutCopyMode = False
'Passage à la ligne suivante
i = i + 1
End If
Next Cell
'tri
If i > 4 Then
.Range("A4:C" & i).Sort Key1:=Range("A4"), Order1:=xlAscending, Key2:=Range("B4") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
End If
'on copie les valeurs
Range(.Range("A4").End(xlToRight), .Range("A4").End(xlDown)).Copy
.Range("A4").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
'On masque les colonnes en trop
For Each Cell In .Range("D4:AH4")
If Cell = 0 Then
Cell.EntireColumn.Hidden = True
Else
Cell.EntireColumn.Hidden = False
End If
Next Cell
'On remplace 38h par N si... et on supprime les N
For Each Cell In .Range(.Range("D4").End(xlToRight), .Range("D4").End(xlDown))
If Cell.Value = "N" Or Cell.Value = 0 Or (Cell.Value = "36H" And .Cells(Cell.Row, 3) = "38H") Then
Cell.ClearContents
End If
Next Cell
'on construit la ligne total
' a noter que le quota pour l'instant à 11 peut être modifier par insertion nom, définir
.Range("A3:AH3").Copy
.Range("A" & i).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Range("A" & i & ":C" & i).Merge
.Range("A" & i).Value = "Total présents - " & Mid(ActiveWorkbook.Names("Quota"), 2)
For Each Cell In .Range("D" & i & ":AH" & i)
Cell.Formula = "=" & i - 4 - CInt(Mid(ActiveWorkbook.Names("Quota"), 2)) _
& "-" & "COUNTA(" & Cells(4, Cell.Column).Address & ":" & .Cells(i - 1, Cell.Column).Address & ")"
Next Cell
'on repasse flag à faux pour éviter de regénérer à chaque activation de la feuille
Flag = False
'et voilà... concernant les formules il s'agit d'un décaler classique associé à un équiv qui détermine quel tableau
'prendre en source
'a noter le nom le_mois paramétré dans insertion nom, il détermine la valeur du mois inscrit en A1
'pour ajouter d'autres mois il faut bien modifier la liste de validation de A1
End With
End Sub
La macro bloque tout d'abord sur 'on masque les colonnes en trop
if cell = 0 THEN
ensuite sur on remplace le 38h par N ......
If Cell.Value = "N" Or Cell.Value = 0 Or (Cell.Value = "36H" And .Cells(Cell.Row, 3) = "38H") Then
Cell.ClearContents
Pour plus de facilité voici les liens du fil de l'époque car il y avait d'autres données peut-être importantes.
https://www.excel-downloads.com/threads/recopier-bd.102128/
Dans l'attente de vous relire je vous remercie d'avance de l'aide que vous pourrez m'apporter
Il y a 5ans Ninbihan m'avait apporté sa précieuse collaboration pour la création d'un programme dont j'utilisais à mon boulot dont l'entreprise fonctionnait sous excell 2003, or suite à la migration de 2003 vers 2010, malheureusement mon tableau ne fonctionne plus.
Voici le code vba :
Public Flag As Boolean
'Flag est une variable qui passe à vrai dès qu'une modif est faite dans BD voir macro évenementielle de BD
'Ensuite lorsque l'on active la feuille projection si cette variable est vrai alors on execute la macro ci dessous
'voir macro évenementielle de projection
Sub generelist()
With Sheets("Projection")
Dim Nbjour As Integer
Dim Cell As Range
'Suppresion des lignes sauf L4 pour garder les formules
If .Range("A4").End(xlDown).Row > 4 And .Range("A4").End(xlDown).Row < 65536 Then
.Range("A5:A" & .Range("A4").End(xlDown).Row).EntireRow.Delete (xlshift)
End If
'Effacement du contenu de la ligne 4
.Range("A4:AH4").ClearContents
'Définition de la première ligne
i = 4
'Boucle balayant toutes les valeurs de BASE DONNEE AGENT
For Each Cell In Sheets("BASE DONNEE AGENT").Range("A2").CurrentRegion
If Not IsEmpty(Cell) And Cell.Row <> 2 Then
.Cells(i, 1) = Sheets("BASE DONNEE AGENT").Cells(2, Cell.Column)
If Right(Cell, 3) = "38H" Or Right(Cell, 3) = "38h" Then 'Ce if détermine la présence de 38 H en fin de nom
.Cells(i, 3) = "38H"
.Cells(i, 2) = Mid(Cell, 1, Len(Cell) - 4)
Else
.Cells(i, 2) = Cell
End If
'Copie du format de La ligne 4
.Range("A4:AH4").Copy
.Range("A" & i).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Copie de le formule calcul voir dans insertion nom
Range("D" & i & ":AH" & i).Formula = "=calcul"
Application.CutCopyMode = False
'Passage à la ligne suivante
i = i + 1
End If
Next Cell
'tri
If i > 4 Then
.Range("A4:C" & i).Sort Key1:=Range("A4"), Order1:=xlAscending, Key2:=Range("B4") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
End If
'on copie les valeurs
Range(.Range("A4").End(xlToRight), .Range("A4").End(xlDown)).Copy
.Range("A4").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
'On masque les colonnes en trop
For Each Cell In .Range("D4:AH4")
If Cell = 0 Then
Cell.EntireColumn.Hidden = True
Else
Cell.EntireColumn.Hidden = False
End If
Next Cell
'On remplace 38h par N si... et on supprime les N
For Each Cell In .Range(.Range("D4").End(xlToRight), .Range("D4").End(xlDown))
If Cell.Value = "N" Or Cell.Value = 0 Or (Cell.Value = "36H" And .Cells(Cell.Row, 3) = "38H") Then
Cell.ClearContents
End If
Next Cell
'on construit la ligne total
' a noter que le quota pour l'instant à 11 peut être modifier par insertion nom, définir
.Range("A3:AH3").Copy
.Range("A" & i).PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
.Range("A" & i & ":C" & i).Merge
.Range("A" & i).Value = "Total présents - " & Mid(ActiveWorkbook.Names("Quota"), 2)
For Each Cell In .Range("D" & i & ":AH" & i)
Cell.Formula = "=" & i - 4 - CInt(Mid(ActiveWorkbook.Names("Quota"), 2)) _
& "-" & "COUNTA(" & Cells(4, Cell.Column).Address & ":" & .Cells(i - 1, Cell.Column).Address & ")"
Next Cell
'on repasse flag à faux pour éviter de regénérer à chaque activation de la feuille
Flag = False
'et voilà... concernant les formules il s'agit d'un décaler classique associé à un équiv qui détermine quel tableau
'prendre en source
'a noter le nom le_mois paramétré dans insertion nom, il détermine la valeur du mois inscrit en A1
'pour ajouter d'autres mois il faut bien modifier la liste de validation de A1
End With
End Sub
La macro bloque tout d'abord sur 'on masque les colonnes en trop
if cell = 0 THEN
ensuite sur on remplace le 38h par N ......
If Cell.Value = "N" Or Cell.Value = 0 Or (Cell.Value = "36H" And .Cells(Cell.Row, 3) = "38H") Then
Cell.ClearContents
Pour plus de facilité voici les liens du fil de l'époque car il y avait d'autres données peut-être importantes.
https://www.excel-downloads.com/threads/recopier-bd.102128/
Dans l'attente de vous relire je vous remercie d'avance de l'aide que vous pourrez m'apporter
) ?
