Using VBA to password protect Excel files

gistfile1.txt

Option Explicit

Public Sub PasswordProtectStatFiles()

Dim Path As String
Dim Subpath As String
Dim Folders As New Collection
Dim File As String
Dim Item As Variant
Dim Wbk As Workbook
Dim cMonth As Date
Dim tMonth As String
Dim lMonth As String
Dim pswrd As String
Dim fsoWbk As Object
Dim wPath As String
Dim aPath As String
Dim pCount As Integer
Dim mCount As Integer

Path = "C:\Statistics\"
Subpath = Dir(Path & "*", vbDirectory)
cMonth = Date
tMonth = Format(cMonth, "yyyymm")
lMonth = Format(DateAdd("m", -1, cMonth), "yyyymm")
pswrd = InputBox("Please type a password.")
pCount = 0
mCount = 0

Do While Not Subpath = ""
    Select Case Subpath
        Case ".", "..", "Statistics.xlsm"
        Case Else
        Folders.Add Item:=Subpath, Key:=Subpath
    End Select
    Subpath = Dir()
Loop

Application.DisplayAlerts = False
For Each Item In Folders
    On Error Resume Next
    wPath = Path & Item & "\"
    aPath = Path & Item & "\archive\"
    File = Dir(wPath & "\*.xls*")
    Do While File ""
        If InStr(File, tMonth) > 0 Then
            Set Wbk = Workbooks.Open(Path & Item & "\" & File)
            Wbk.Password = pswrd
            Wbk.Save
            Wbk.Close
            pCount = pCount + 1
        Else
            If InStr(File, lMonth) > 0 Then
                Set fsoWbk = CreateObject("scripting.filesystemobject")
                fsoWbk.CreateFolder (aPath)
                fsoWbk.MoveFile Source:=wPath & File, Destination:=aPath
                mCount = mCount + 1
            End If
        End If
        File = Dir()
    Loop
Next Item
Application.DisplayAlerts = True

MsgBox "Process complete. " & pCount & " files password protected and " & mCount & " files archived."

End Sub