ByPassing Passwords when pulling stats from external password-protected files

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,

Sweet, that opened with no problem. Nice layout on the "Summary" sheet. Is that your handy work?

Hello jameztown,

I ran the updated macro on using the files you sent and it worked fine on my end. Check it out and let me know how it goes. Here is the updated macro.

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

Sub UpdateAll()

  Dim Cell As Range
  Dim Data() As Variant
  Dim Filename As String
  Dim Passwords As Object
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wkb As Workbook
  Dim WkbName As String
  Dim WkbPath As String
  Dim WeekDate As String
  Dim WeekRng As Range
  
    If ActiveSheet.Name = "Passwords" Then
       MsgBox "You Can Not Run the Macro on this Worksheet."
       Exit Sub
    End If
    
    WeekDate = SheetNameToDate(ActiveSheet.Name)
    
    Set Rng = Range("A4")
    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")
            Set WeekRng = .Range("A16")
            Set RngEnd = .Cells(Rows.Count, "A").End(xlUp).Offset(-1, 0)
            If RngEnd.Row <= WeekRng.Row Then GoTo NextWkb
              For R = WeekRng.Row To RngEnd.Row
                If StrComp(.Cells(R, "A").Text, WeekDate, vbTextCompare) = 0 Then
                  Data = Array(.Cells(R, "C").Value, .Cells(R, "D").Value, .Cells(R, "E").Value, _
                     .Cells(R, "F").Value, .Cells(R, "G").Value, .Cells(R, "H").Value, _
                     .Cells(R, "I").Value, .Cells(R, "J").Value, .Cells(R, "M").Value, _
                     .Cells(R, "N").Value, .Cells(R, "O").Value, .Cells(R, "Q").Value, _
                     .Cells(R, "R").Value, .Cells(R, "S").Value, .Cells(R, "T").Value, _
                     .Cells(R, "U").Value, .Cells(R, "V").Value, .Cells(R, "W").Value)
                End If
              Next R
          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

This is a New Macro that was added in Module2

'Written: May 26, 2010
'Author:  Leith Ross
'Summary: Converts a sheet name like Mar27 into a date string like "27-mar-2010"

Function SheetNameToDate(ByVal ShtName As String) As String

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