ByPassing Passwords when pulling stats from external password-protected files

okay, brand new here... i just can't wrap my head around my problem; super hopeful that somebody can help me out here...

I have used excel to create a stat monitoring system to our work's employees. They enter their stats for the week, and I tablulate their stats for the manager's to review. There's only 50 employees in our non-profit organization. All of these stat files work perfectly.

So, now I'm at the point where I'm trying to create a manager file to review the performance stats of our employees. I'm trying to create a system that doesn't insist that each manager type in 50 passwords whenever they wanted an update on stats.

So, I have two worksheets.

One worksheet, called 'Passwords', shows the external file name [firstname_lastname_stats.xls] in A1 and their password in B1. This goes to A50 and B50 respectively. I have all of the external stat file names and their respective passwords in this file.

The other worksheet just pulls various stat totals already calculated from the external file.

How can I set this up so the manager doesn't have to type in all of these passwords? Any ideas? Thanks very much!

What have you got so far?

To best describe or illustrate your problem you would be better off attaching a dummy workbook, the workbook should contain the same structure and some dummy data of the same type as the type you have in your real workbook - so, if a cell contains numbers & letters in this format abc-123 then that should be reflected in the dummy workbook.

If needed supply a before and after sheet in the workbook so the person helping you can see what you are trying to achieve.

Doing this will ensure you get the result you need!

Hello jameztown,

Welcome to the Forum!

You will need a VBA macro to open the workbooks since they are password protected. It isn't clear from your post if you have any formulas or VBA code already in place or you need all help constructing these. If you have a workbook, it would help if you posted it.

thanks... I didn't realize I could upload my workbook. I've made a similar file, taking out some names.

I currently don't have any VBA on the file; although I try to attempt to code this out. I've deleted that avoid any confusion.

Basically, I just need the code that will bypass the request that asks for each employees password.

Thanks so much for your help!

Hello jameztown,

The attached workbook is fully automated. The workbook names are built from the names on the active sheet in column "A". Each workbook is opened and the summary information is copied from the workbook to the active sheet columns "C:Q".

I added a button on the worksheet to run the macro. If you have a lot of sheets, you may want to add a shortcut key to the macro rather than adding buttons and assigning the macro to each button on each sheet. Here is the macro code.

'Written: May 24, 2010
'Author:  Leith Ross

Sub UpdateAll()

  Dim Cell As Range
  Dim Data() As Variant
  Dim Passwords As Object
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wkb As Workbook
  Dim WkbName As String
  
    On Error GoTo ErrorHandler
  
    If ActiveSheet.Name = "Passwords" Then
       MsgBox "You Can Not Run the Macro on this Worksheet."
       Exit Sub
    End If
    
    Set Rng = Range("A3")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    
    If RngEnd.Row < Rng.Row Or Rng.Cells(1, 1) = "" Then
       MsgBox "There is no data on '" & ActiveSheet.Name & "'", vbOKOnly + vbExclamation
       Exit Sub
    Else
       Set Rng = Range(Rng, RngEnd)
    End If
      
    Application.ScreenUpdating = False
    
      Set Passwords = CreateObject("Scripting.Dictionary")
      Passwords.CompareMode = vbTextCompare
      
      For Each Cell In Worksheets("Passwords").Range("A1").CurrentRegion.Columns(1).Cells
        If Not Passwords.Exists(Cell.Text) Then
           Passwords.Add Cell.Text, Cell.Offset(0, 1).Text
        End If
      Next Cell
      
      For Each Cell In Rng
        WkbName = Join(Split(Cell.Text, " "), "_") & "_stats.xls"
        Set Wkb = Workbooks.Open(Filename:=WkbName, Password:=Passwords(WkbName))
          With Wkb.Worksheets("Summary")
            Data = Array(.Cells(16, "C"), .Cells(16, "D"), .Cells(16, "E"), _
                         .Cells(16, "F"), .Cells(16, "G"), .Cells(16, "H"), _
                         .Cells(16, "I"), .Cells(16, "J"), .Cells(16, "M"), _
                         .Cells(16, "N"), .Cells(16, "O"), .Cells(16, "Q"), _
                         .Cells(16, "R"), .Cells(16, "S"), .Cells(16, "W"))
          End With
        Wkb.Close SaveChanges:=False
        Rng.Offset(0, 1) = Format(Now(), "shortdate")
        Rng.Offset(0, 2).Resize(1, UBound(Data) + 1).Value = Data
      Next Cell
      
ErrorHandler:
    Set Passwords = Nothing
    Application.ScreenUpdating = True
    MsgBox "Run-time error '" & Err.Number & "':" & vbCrLf & vbCrLf & Err.Description
    
End Sub

Wow... thanks for your help thus far; i've spent about 6 hours on this trying to make it work! you are incredibly helpful; i can't even tell you...

i get an error message when pressing the update button. it can't find my external worksheets. it's looking for the correct file [firstname_lastname_stats.xls] but it's giving me a run time error [1004]. I've tried moving this file around, wondering if it's reaching for the files in a subfolder; but, still can't get it to work. Any ideas?

Right now, it should be looking in the same folder. I've placed summary.xls right next to all of the firstname_lastname_stats.xls files.

Hello jameztown,

Can you tell me the error number? In the macro it is looking for the worksheet "Summary" in the workbooks being opened. Are you using a different name? If so, you will need to change the name in the macro to match the worksheet name you are using.

Hello jameztown,

I need to see the workbook. Can you post a copy?

okay; this is a copy of the workbook. I've just had to delete some last names; but, it should still show the errors that are coming up still... when I click 'update', the code under 'stats updated' - which should be blank - changes to 520ort25ate. If I press it again, it changes to 2522ort24ate. This loop is continuous. I'm not sure if that helps, though.

Hello jameztown,

Thanks for posting the workbook with the error. I have corrected the problem. I had made a typo. I typed "shortdate" when I should have typed "short date". Everything should now. Here is the corrected code. This has already been added to the attached workbook.

'Written: May 24, 2010
'Author:  Leith Ross

Sub UpdateAll()

  Dim Cell As Range
  Dim Data() As Variant
  Dim Filename As String
  Dim Passwords As Object
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wkb As Workbook
  Dim WkbName As String
  Dim WkbPath As String
  
    On Error GoTo ErrorHandler
  
    If ActiveSheet.Name = "Passwords" Then
       MsgBox "You Can Not Run the Macro on this Worksheet."
       Exit Sub
    End If
    
    Set Rng = Range("A3")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    
    If RngEnd.Row < Rng.Row Or Rng.Cells(1, 1) = "" Then
       MsgBox "There is no data on '" & ActiveSheet.Name & "'", vbOKOnly + vbExclamation
       Exit Sub
    Else
       Set Rng = Range(Rng, RngEnd)
    End If
      
    Application.ScreenUpdating = False
      
      WkbPath = ThisWorkbook.Path & "\"
      
      Set Passwords = CreateObject("Scripting.Dictionary")
      Passwords.CompareMode = vbTextCompare
      
      For Each Cell In Worksheets("Passwords").Range("A1").CurrentRegion.Columns(1).Cells
        If Not Passwords.Exists(Cell.Text) Then
           Passwords.Add Cell.Text, Cell.Offset(0, 1).Text
        End If
      Next Cell
      
      For Each Cell In Rng
        WkbName = Join(Split(Cell.Text, " "), "_") & "_stats.xls"
        Filename = WkbPath & WkbName
        Set Wkb = Workbooks.Open(Filename:=Filename, Password:=Passwords(WkbName))
          With Wkb.Worksheets("Summary")
            Data = Array(.Cells(16, "C"), .Cells(16, "D"), .Cells(16, "E"), _
                         .Cells(16, "F"), .Cells(16, "G"), .Cells(16, "H"), _
                         .Cells(16, "I"), .Cells(16, "J"), .Cells(16, "M"), _
                         .Cells(16, "N"), .Cells(16, "O"), .Cells(16, "Q"), _
                         .Cells(16, "R"), .Cells(16, "S"), .Cells(16, "W"))
          End With
        Wkb.Close SaveChanges:=False
        Rng.Offset(0, 1) = Format(Now(), "Short Date")
        Rng.Offset(0, 2).Resize(1, UBound(Data) + 1).Value = Data
      Next Cell
      
ErrorHandler:
    Set Passwords = Nothing
    Application.ScreenUpdating = True
    MsgBox "Run-time error '" & Err.Number & "':" & vbCrLf & vbCrLf & Err.Description
    
End Sub

Hello jameztown,

I have updated the macro and tested it. On my end it works correctly. Let me know how it runs for you. Here is the updated code and workbook.

'Written: May 25, 2010
'Author:  Leith Ross

Sub UpdateAll()

  Dim Cell As Range
  Dim Data() As Variant
  Dim Filename As String
  Dim Passwords As Object
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wkb As Workbook
  Dim WkbName As String
  Dim WkbPath As String
  
    If ActiveSheet.Name = "Passwords" Then
       MsgBox "You Can Not Run the Macro on this Worksheet."
       Exit Sub
    End If
    
    Set Rng = Range("A3")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    
    If RngEnd.Row < Rng.Row Or Rng.Cells(1, 1) = "" Then
       MsgBox "There is no data on '" & ActiveSheet.Name & "'", vbOKOnly + vbExclamation
       Exit Sub
    Else
       Set Rng = Range(Rng, RngEnd)
    End If
      
    Application.ScreenUpdating = False
      
      WkbPath = ThisWorkbook.Path & "\"
      
      Set Passwords = CreateObject("Scripting.Dictionary")
      Passwords.CompareMode = vbTextCompare
      
      For Each Cell In Worksheets("Passwords").Range("A1").CurrentRegion.Columns(1).Cells
        If Not Passwords.Exists(Cell.Text) Then
           Passwords.Add Cell.Text, Cell.Offset(0, 1).Text
        End If
      Next Cell
      
      For Each Cell In Rng
        WkbName = Join(Split(Cell.Text, " "), "_") & "_stats.xls"
        Filename = WkbPath & WkbName
        On Error Resume Next
        Set Wkb = Workbooks.Open(Filename:=Filename, Password:=Passwords(WkbName))
        If Err = 1004 Then Err.Clear: GoTo NextWkb
          With Wkb.Worksheets("Summary")
            Data = Array(.Cells(16, "C").Value, .Cells(16, "D").Value, .Cells(16, "E").Value, _
                         .Cells(16, "F").Value, .Cells(16, "G").Value, .Cells(16, "H").Value, _
                         .Cells(16, "I").Value, .Cells(16, "J").Value, .Cells(16, "M").Value, _
                         .Cells(16, "N").Value, .Cells(16, "O").Value, .Cells(16, "Q").Value, _
                         .Cells(16, "R").Value, .Cells(16, "S").Value, .Cells(16, "W").Value)
          End With
        Wkb.Protect Password:=Passwords(WkbName)
        Wkb.Close SaveChanges:=True
        Cell.Offset(0, 2).Resize(1, UBound(Data) + 1).Value = Data
NextWkb:
      Next Cell
      
    Set Passwords = Nothing
    Application.ScreenUpdating = True
    
End Sub

Hello jameztown,

Are you saying each workbook will have more than just the "Summary" sheet and the same columns will be used but the row will change? Will each workbook have the same number of sheets? Will each sheet use only a specific row like "Summary" is row 16, "First Quarter" is row 18, etc?

Originally Posted by Leith Ross

Hello jameztown,

Are you saying each workbook will have more than just the "Summary" sheet and the same columns will be used but the row will change? Will each workbook have the same number of sheets? Will each sheet use only a specific row like "Summary" is row 16, "First Quarter" is row 18, etc?

Hi Leith... yes; sorry. there is a summary sheet for each week of the year. all of the summary sheets are the same except they're pulling from the external sheet two lines below the previous week.

All of the external workbooks are exactly the same; but with different stats. I've attached a new file showing this. I've also attached an example external sheet.

Sorry! I'm confused; i thought I could take over from here as it seemed simple at first thought

Hello jameztown,

You will need to upload the "craig_h_stats" again. It is protected and all my software says it isn't an Excel file - WTF???

Hello jameztown,

I have added the fiscal year fix to the second macro. Here is the code. Replace Module 2's with this.

'Written: May 26, 2010
'Updated: May 27, 2010 - Year changes based on months of fiscal year
'Author:  Leith Ross
'Summary: Converts a sheet name like Mar27 into a date string like "27-mar-2011"

Function SheetNameToDate(ByVal ShtName As String) As String

  Dim DateText As String
  Dim RegExp As Object
  Dim Y As Integer
  
    Y = Year(Now())
    
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.IgnoreCase = True
    RegExp.Pattern = "([A-Za-z]{3})(\d{1,2})"
    
      If RegExp.Test(ShtName) = True Then
         Select Case LCase(RegExp.Replace(ShtName, "$1"))
           Case Is = "jan", "feb", "mar"
             Y = Y + 1
         End Select
         DateText = RegExp.Replace(ShtName, "$2-$1-" & Y)
      Else
         MsgBox "Could Not Convert Sheet Name '" & ShtName & "' to a Date."
      End If
    
    SheetNameToDate = DateText
    Set RegExp = Nothing
    
End Function

Hello jameztown,

I just looked at the sheet "Mar27" in the "Summary" workbook. I think I need new glasses. You have the full date in cell "I1" - 27-Mar-2010. Let me make another change to this and I'll post the macro code and the workbook.