sebbbbb
XLDnaute Impliqué
Bonjour
j'utilise le script suivant qui me lance un message d'erreur lorsque activé (je precise aucune feuille n'est protégée)
lorsque je clique sur débogage :
ci-dessous la totalité du script. Voyez vous la raison du prob svp ?
Sub Ajouter()
ActiveWorkbook.Unprotect ""
Dim TWsh(1 To 12) As Worksheet, N As Long, NomF, Rng As Range, M As Long, NSrc As String, NCbl As String
Set TWsh(1) = ActiveSheet
For N = 2 To 6
Set TWsh(N) = ActiveWorkbook.Worksheets(TWsh(1).Index - 1 + N)
Next N
For N = 7 To 12
TWsh(N - 6).Copy After:=TWsh(N - 1)
Set TWsh(N) = ActiveSheet
NomF = TWsh(N - 6).Name
TWsh(N).Name = Left$(NomF, Len(NomF) - 1) & Right$(NomF, 1) + 1
Next N
For N = 7 To 12
Set Rng = TWsh(N).Cells.SpecialCells(xlCellTypeFormulas, 23)
For M = 1 To 6
' AdrSrc = TWsh(M).[A1].Address(External:=True)
' AdrCbl = TWsh(M + 6).[A1].Address(External:=True)
' AdrSrc = Mid$(AdrSrc, InStr(AdrSrc, "]") + 1): AdrSrc = Left$(AdrSrc, InStr(AdrSrc, "!"))
' AdrCbl = Mid$(AdrCbl, InStr(AdrCbl, "]") + 1): AdrCbl = Left$(AdrCbl, InStr(AdrCbl, "!"))
NSrc = TWsh(M).Name: NCbl = TWsh(M + 6).Name
Rng.Replace What:=NSrc & "!", Replacement:=NCbl & "!", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Rng.Replace What:="'" & NSrc & "'!", Replacement:="'" & NCbl & "'!", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next M, N
TWsh(1).Shapes(Application.Caller).Delete
ActiveSheet("BL impr.1").Select
Range("C5").Select
ActiveWorkbook.Protect ""
End Sub
merci
Seb
j'utilise le script suivant qui me lance un message d'erreur lorsque activé (je precise aucune feuille n'est protégée)
lorsque je clique sur débogage :
ci-dessous la totalité du script. Voyez vous la raison du prob svp ?
Sub Ajouter()
ActiveWorkbook.Unprotect ""
Dim TWsh(1 To 12) As Worksheet, N As Long, NomF, Rng As Range, M As Long, NSrc As String, NCbl As String
Set TWsh(1) = ActiveSheet
For N = 2 To 6
Set TWsh(N) = ActiveWorkbook.Worksheets(TWsh(1).Index - 1 + N)
Next N
For N = 7 To 12
TWsh(N - 6).Copy After:=TWsh(N - 1)
Set TWsh(N) = ActiveSheet
NomF = TWsh(N - 6).Name
TWsh(N).Name = Left$(NomF, Len(NomF) - 1) & Right$(NomF, 1) + 1
Next N
For N = 7 To 12
Set Rng = TWsh(N).Cells.SpecialCells(xlCellTypeFormulas, 23)
For M = 1 To 6
' AdrSrc = TWsh(M).[A1].Address(External:=True)
' AdrCbl = TWsh(M + 6).[A1].Address(External:=True)
' AdrSrc = Mid$(AdrSrc, InStr(AdrSrc, "]") + 1): AdrSrc = Left$(AdrSrc, InStr(AdrSrc, "!"))
' AdrCbl = Mid$(AdrCbl, InStr(AdrCbl, "]") + 1): AdrCbl = Left$(AdrCbl, InStr(AdrCbl, "!"))
NSrc = TWsh(M).Name: NCbl = TWsh(M + 6).Name
Rng.Replace What:=NSrc & "!", Replacement:=NCbl & "!", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Rng.Replace What:="'" & NSrc & "'!", Replacement:="'" & NCbl & "'!", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next M, N
TWsh(1).Shapes(Application.Caller).Delete
ActiveSheet("BL impr.1").Select
Range("C5").Select
ActiveWorkbook.Protect ""
End Sub
merci
Seb