ByPassing Passwords when pulling stats from external password-protected files

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,

That is such a wonderfully vague error. The macro assumes the other files to be in the current directory. Maybe I need to change the macro to look in specific directory. Are these workbooks in the same folder as the workbook with the macro?

Hello jameztown,

I have added another variable to the macro called WkbPath. This variable nows holds the directory path of the workbook with the macro. This is now used with the other workbook names when opened. Here is the update code. This has been added to the attached workbook as well.

'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
  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 = WkbPath & 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