Discussion :

[Oh so sick]

Bonjour tout le monde !

J'aimerai tester la présence d'une feuille ou dans un autre classeur qui contient les archives des feuilles de pointage.

Actuellement j'utilise cette fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Function Existe(ByVal Wbk As Workbook, ByVal Str As String) As Boolean
Dim Sh As Worksheet
For Each Sh In Wbk.Sheets
    If UCase(Sh.Name) = UCase(Str) Then
        Existe = True
        Exit For
    End If
Next Sh
End Function

Avec ce code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Sub Enregistrecommun()
Dim Chemin As String, Fichier As String, Fact As String
Dim Wbk As Workbook
Dim Sh As Worksheet
Application.ScreenUpdating = False
Chemin = "/Users/joan/Desktop/AXIANS/"
Fichier = "Feuille de pointage commun.xlsx"
Fact = "S" & Workbooks("Feuille de pointage.xlsm").Worksheets("Pointage").Range("L6").Value & " - " & Workbooks("Feuille de pointage.xlsm").Worksheets("Pointage").Range("I6")
If Dir(Chemin & Fichier) = "" Then
    Set Wbk = Workbooks.Add(1)
    Set Sh = Wbk.Worksheets(1)
    Sh.Name = Fact
    Wbk.SaveAs Chemin & Fichier
Else
    Set Wbk = Workbooks.Open(Chemin & Fichier)
    If Not Existe(Wbk, Fact) Then
        Set Sh = Wbk.Worksheets.Add(before:=Wbk.Sheets(1))
        Sh.Name = Fact
        ThisWorkbook.Worksheets(Fact).Shapes("Image 1").Copy
        ActiveSheet.Range("D39").PasteSpecial
        ThisWorkbook.Worksheets(Fact).Range("A1:Q37").Copy
        Wbk.Worksheets(Fact).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        Wbk.Worksheets(Fact).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        Wbk.Worksheets(Fact).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        Wbk.Worksheets(Fact).Range("A1").Select
        ActiveWindow.Zoom = 75
        Workbooks("Feuille de pointage.xlsm").Worksheets("Pointage").Activate
        Worksheets("Pointage").Range("D11:P35").ClearContents
        Worksheets("Pointage").Range("R3").ClearContents
       Sheets("Pointage").Shapes("Confirmation").DrawingObject.Value = 0
       Sheets("Pointage").Shapes("imprimer").DrawingObject.Value = 0
        Set Sh = Nothing
        Wbk.Close True
        Set Wbk = Nothing   
    Else
    Set Sh = Wbk.Worksheets(Fact)
        ThisWorkbook.Worksheets(Fact).Range("A1:Q37").Copy
        Wbk.Worksheets(Fact).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        Wbk.Worksheets(Fact).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        Wbk.Worksheets(Fact).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    ActiveSheet.Range("A1").Select
        Wbk.Worksheets(1).Activate
        Workbooks("Feuille de pointage.xlsm").Worksheets(Fact).Activate
        Worksheets(Fact).Range("A1").Select
        Worksheets("Pointage").Activate
              Worksheets("Pointage").Range("D11:P35").ClearContents
    Worksheets("Pointage").Range("R3").ClearContents
    Sheets("Pointage").Shapes("Confirmation").DrawingObject.Value = 0
    Sheets("Pointage").Shapes("imprimer").DrawingObject.Value = 0
        Set Sh = Nothing
        Wbk.Close True
        Set Wbk = Nothing      
    End If
End If
End Sub

Si la feuille existe il le remplace, sinon il la créer, et il enregistre le document et le ferme.
Cependant le code pose problème, si un autre classeur est ouvert il l'utilise pour le code.

J'avais exactement le même principe pour enregistrer la nouvelle feuille non pas sur le commun mais sur un classeur personnel, je l'ai donc changé pour cette fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Public Function FeuilleInexistante(ByVal strNomFeuille As String) As Boolean
 
FeuilleInexistante = IsError(Evaluate("='" & strNomFeuille & "'!A1"))
 
End Function

Il retourne TRUE si strNomFeuille est le nom d'une feuille qui n'existe pas dans le classeur actif.

Je l'utilise avec ce code dans mon module :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub Enregistrefeuille()
Dim x As Integer
strNomFeuille = "S" & Workbooks("Feuille de pointage.xlsm").Worksheets("Pointage").Range("L6").Value & " - " & Workbooks("Feuille de pointage.xlsm").Worksheets("Pointage").Range("I6")
If FeuilleInexistante(strNomFeuille) Then
With ThisWorkbook
        .Sheets.Add(After:=.Sheets(1)).Name = strNomFeuille
        ActiveWindow.Zoom = 75
        ActiveWindow.DisplayGridlines = False
End With
        Worksheets("Pointage").Shapes("Image 1").Copy
        Worksheets(strNomFeuille).Range("D39").PasteSpecial
        Worksheets("Pointage").Range("A1:Q37").Copy
With Worksheets(strNomFeuille).Range("A1")
       .PasteSpecial xlPasteValuesAndNumberFormats 'Paste only the values and how the values are formatted
       .PasteSpecial Paste:=8 ' Paste the column widths
       .PasteSpecial xlPasteFormats ' Paste cell formats (boarders, colors, etc)
End With
Else
        Worksheets("Pointage").Range("A1:Q37").Copy
With Worksheets(strNomFeuille).Range("A1")
        .PasteSpecial xlPasteValuesAndNumberFormats 'Paste only the values and how the values are formatted
        .PasteSpecial Paste:=8 ' Paste the column widths
        .PasteSpecial xlPasteFormats ' Paste cell formats (boarders, colors, etc)
End With
End If
        Application.CutCopyMode = False
With Worksheets("Pointage")
        .Activate
        .Range("D11:P35").ClearContents
        .Range("R3").ClearContents
        .Shapes("Confirmation").DrawingObject.Value = 0
        .Shapes("imprimer").DrawingObject.Value = 0
End With
End Sub

Le code peut sembler lourd pour copier les informations mais j'utilise les cellules I6 et L6 pour indiquer automatiquement la semaine en cours avec la cellule R3 pour modifier ou créer une semaine spécifique. A l'avenir je compte changer l'utilisation de formule dans ces cellules pour l'intégrer en VBA et donc pouvoir utiliser la méthode de transfert plutôt qu'un specialpast.

Voilà est-il possible selon vous d'adapter la fonction feuilleinexistante afin qu'elle teste la présence ou non du classeur sur le commun, qu'elle le créer si il n'est pas présent, qu'elle teste également l'existence ou non d'une feuille ?

De plus, il y a t'il des choses a améliorer dans le codage ?

Toute aide est la bienvenue, je vous remercie

Ci-joint mon classeur Excel, j'ai désactiver la fonction enregistre commun, il faut remplacer enregistrefeuille pour la réactiver.