Poner password a 1600 excel del tiron!

Hola Mario,

Prueba poner los 1600 archivos en una carpeta (p.ej. el codigo usa el directorio "C:\Temp") y ejecutar el codigo que te pongo a continuacion desde cualquier otro libro abierto.

Saludos,
KL

'-Inicio Codigo--
Sub ProtegerArchivos()
Dim sBusc As String, sArchivo As String
Dim sRuta As String, sFiltro As String, sClave As String

sRuta = "C:\Temp" 'ruta hacia la carpeta
sFiltro = "*.xls"
sClave = "abracadabra"

If Right(sRuta, 1) <> "\" Then sRuta = sRuta & "\"
sBusc = Dir(sRuta & sFiltro)

'Sacamos la lista de los ficheros
If sBusc = "" Then Exit Sub

With Application
.StatusBar = "Protegiendo archivos. Espere por favor..."
.ScreenUpdating = False
.DisplayAlerts = False
Do While sBusc <> ""
sArchivo = sRuta & sBusc
Select Case sArchivo
Case ThisWorkbook.FullName
Case Else
With Workbooks.Open(sArchivo)
.SaveAs sArchivo, , sClave
.Close
End With
End Select
sBusc = Dir()
Loop
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = False
End With
MsgBox "La operacion ha finalizado."
End Sub
'-Fin Codigo--