tinet
XLDnaute Impliqué
Bonjour le forum,
J'ai besoin de l'oeil d'un expert pour positionner la protection sur ma macro.
je suis arrivé à mettre une protection, ajouter et enlever sur le feuille "modele"
mais je dois protéger la feuilles principales "liste" à l'exécution de ma macro.
idem je dois mette une protection sur le classeur.
voici ma macro
j'ai également un Useform pour la suppression
idem j'ai besoin de mot de passe
merci à plus
J'ai besoin de l'oeil d'un expert pour positionner la protection sur ma macro.
je suis arrivé à mettre une protection, ajouter et enlever sur le feuille "modele"
mais je dois protéger la feuilles principales "liste" à l'exécution de ma macro.
idem je dois mette une protection sur le classeur.
voici ma macro
PHP:
Option Explicit
Sub Ajout()
Dim i As Long, Adr As String
Dim LastRow As Long, sNomFeuille As String
Dim Rng As Range
ActiveSheet.Unprotect Password:=Feuil3.Range("A1").Value
LastRow = ShListe.Range("A" & ShListe.Range("A:A").Rows.Count).End(xlUp).Row
Sheets("modele").Visible = True
Application.ScreenUpdating = False
TriNoms
If VerifDoublon = True Then
Application.ScreenUpdating = True
MsgBox "Doublon trouvé", vbOKOnly, "Attention"
Exit Sub
End If
LinkShModele
For i = LastRow To 2 Step -1
Set Rng = ShListe.Cells(i, 1)
sNomFeuille = NomFeuilleValide(ShListe.Cells(i, 2))
If ExistenceFeuille(sNomFeuille) = False Then
ShModele.Copy After:=ShModele
ActiveSheet.Name = sNomFeuille
ActiveSheet.Range("c1").Value = Rng
Adr = sNomFeuille & "!A10"
ShListe.Hyperlinks.Add _
Anchor:=Rng, Address:="", _
SubAddress:=Adr
Sheets("modele").Visible = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=Feuil3.Range("A1").Value
End If
Next i
With ShListe
.Activate
End With
With ActiveWindow
.ScrollColumn = 1
.ScrollRow = 1
End With
Application.ScreenUpdating = True
End Sub
Private Sub DeleteAll()
Dim LastRow As Long, i As Long
Dim sNomFeuille As String
LastRow = ShListe.Range("A" & ShListe.Range("A:A").Rows.Count).End(xlUp).Row
If LastRow = 1 Then Exit Sub
For i = LastRow To 2 Step -1
sNomFeuille = ShListe.Cells(i, 2)
If ExistenceFeuille(sNomFeuille) Then
Application.DisplayAlerts = False
Sheets(sNomFeuille).Delete
ShListe.Cells(i, 1).Clear
Application.DisplayAlerts = True
End If
Next i
End Sub
Function ExistenceFeuille(ByVal sNomFeuille As String) As Boolean
On Error Resume Next
ExistenceFeuille = Sheets(sNomFeuille).Name <> ""
Err.Clear
End Function
Private Sub LinkShModele()
With ShModele
.Activate
.Hyperlinks.Add _
Anchor:=ShModele.Range("A45"), Address:="", _
SubAddress:=ShListe.Name & "!c1", TextToDisplay:="Retour Liste"
End With
End Sub
Private Function NomFeuilleValide(ByVal sNom As String) As String
Const CaracInterdits As String = ":/\?*[]"
Dim i As Integer, Car As String * 1
If Len(sNom) = 0 Then Exit Function
For i = 1 To Len(CaracInterdits)
Car = Mid(CaracInterdits, i, 1)
sNom = Replace(sNom, Car, "")
Next
NomFeuilleValide = Trim(sNom)
End Function
Sub SuppFeuille(ByVal sNomFeuille As String)
Const msg1 As String = "Cette feuille n'existe pas"
If ExistenceFeuille(sNomFeuille) Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets(sNomFeuille).Delete
ShListe.Cells(2 + UserForm1.cboListe.ListIndex, 1).Clear
TriNoms
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
MsgBox msg1, vbOKOnly & vbQuestion, "Feuille Introuvable"
End If
End Sub
Sub Supprimer()
UserForm1.Show
End Sub
Private Sub TriNoms()
Dim LastRow As Long
LastRow = ShListe.Range("A" & ShListe.Range("A:A").Rows.Count).End(xlUp).Row
With ShListe
.Range("A2:b2" & LastRow).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess
End With
End Sub
Private Function VerifDoublon() As Boolean
Dim Coll As Collection, LastRow As Long, i As Long
VerifDoublon = False
Set Coll = New Collection
LastRow = ShListe.Range("A" & ShListe.Range("A:A").Rows.Count).End(xlUp).Row
For i = 1 To LastRow
On Error Resume Next
Coll.Add ShListe.Cells(i, 1), CStr(ShListe.Cells(i, 1))
If Err.Number = 457 Then
ShListe.Cells(i, 1).Select
VerifDoublon = True
Set Coll = Nothing
Exit Function
End If
Next i
Set Coll = Nothing
End Functionj'ai également un Useform pour la suppression
idem j'ai besoin de mot de passe
PHP:
Option Explicit
Private Sub cmdAnnuler_Click()
Unload Me
End Sub
Private Sub cmdSupprimer_Click()
Dim Lg
If cboListe.ListIndex = -1 Then Exit Sub
Lg = Application.Match(cboListe, Sheets("Liste").Columns(1), 0)
If Not IsError(Lg) Then
SuppFeuille Sheets("Liste").Cells(Lg, 2)
UserForm_Initialize
End If
End Sub
Private Sub UserForm_Initialize()
Dim LastRow As Long, i As Long
LastRow = ShListe.Range("A" & ShListe.Range("A:A").Rows.Count).End(xlUp).Row
cboListe.Clear
For i = 2 To LastRow
cboListe.AddItem ShListe.Cells(i, 1)
Next i
Range("A2:A333").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A2").Select
End Submerci à plus
