Sub to open n close .xls files in folders

[Max]

I've got a bunch of .xls files in a folder, like this

D:\Campaign Sys (main folder)
-- C001 (subfolder)
-------- Br001 (subfolder)
---------------RM01_C001.xls
---------------RM02_C001.xls
-------- Br002 (subfolder)
---------------RM03_C001.xls
---------------RM04_C001.xls
etc

In Sheet1,
I've listed all the folder paths in A2 down:
D:\Campaign Sys\C001\Br001
D:\Campaign Sys\C001\Br002
etc

In another sheet named: Passwd
I've got the list of passwords* in cols A to C
data from row2 down
*passwords to open are listed in C2 down

RM Branch Pwd
RM01 Br001 1111
RM02 Br001 1112
RM03 Br002 1113
RM04 Br002 1114
etc

For daily updating purposes,
I need to run a sub to open all the .xls files
in all the folder paths at 9.00 pm daily
and then to close all files w/o saving an hour later at 10 pm

Appreciate any help to achieve the above. Thanks

 

[Dave Peterson]

First, you can use an ontime macro to close your files--or just close excel????.

Chip Pearson has lots of notes here:
http://www.cpearson.com/excel/OnTime.aspx

I _think_ this works ok. There isn't much validation--no check to see if your
passwords are correct (for instance).

Option Explicit
Sub testme01()

Dim myNames() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim wks As Worksheet
Dim TempWkbk As Workbook
Dim myCell As Range
Dim myRng As Range
Dim res As Variant
Dim myFormula As String
Dim myTable As Range

Set wks = Worksheets("passwd")

With wks

Set myTable = .Range("a2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row)

'the subfolder names in column B
Set myRng = .Range("b1", .Cells(.Rows.Count, "b").End(xlUp))

'clean up column F
.range("F1").entirecolumn.clearcontents

myRng.AdvancedFilter Action:=xlFilterCopy, _
copytorange:=.Range("f1"), _
unique:=True

Set myRng = .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))

End With

For Each myCell In myRng.Cells
'change to point at the folder to check
myPath = "d:\Campaign Sys\C001\" & myCell.Value
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "no files found for: " & myPath
Else
'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myNames(1 To fCtr)
myNames(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then
For fCtr = LBound(myNames) To UBound(myNames)
' duplicate this formula in
code
' =index($c$1:$c$100,
' match(1,("rm01"=$a$1:$a$100)
' *("br001"=$b$1:$b$100),0))

myFormula = "index(" & myTable.Columns(3).Address & "," _
& "match(1,(" & Chr(34) & Left(myNames(fCtr), 4) _
& Chr(34) & "=" & myTable.Columns(1).Address & ")" _
& "*(" & Chr(34) & myCell.Value & Chr(34) & "=" _
& myTable.Columns(2).Address & "),0))"

'Debug.Print myFormula 'for checking

'use the cells on wks--not application.evaluate!
res = wks.Evaluate(myFormula)

If IsError(res) Then
MsgBox "No password for: " & myNames(fCtr)
Else
Set TempWkbk = Workbooks.Open _
(Filename:=myPath & myNames(fCtr), _
Password:=res, _
ReadOnly:=True)
'do other stuff if you want
'TempWkbk.Close savechanges:=false 'or true
End If
Next fCtr
End If
End If
Next myCell

'clean up column F
wks.range("F1").entirecolumn.clearcontents
End Sub

 

[Joel]

I haven't test the code yetr but try this. Let me know if you have probelms.


Sub openfiles()

Application.Wait "21:00:00"

Dim Bks() As Variant

BookCount = 0
With Sheets("sheet1")
RowCount = 2
Do While .Range("A" & RowCount) <> ""
Folder = .Range("A" & RowCount)
FName = Dir(Folder & "\*.xls")
'get base name of folder
BaseName = Folder
Do While InStr(BaseName, "/") > 0
BaseName = Mid(BaseName, InStr(BaseName, "/") + 1)
Loop
'get password
With Sheets("PassWd")
'remove xls from filename
BFName = Left(FName, InStr(FName, ".") - 1)
PassWdRowCount = 2
Do While .Range("A" & PassWdRowCount) <> ""
If .Range("B" & PassWdRowCount) = Folder And _
.Range("B" & PassWdRowCount) = BFName Then

BkPassword = .Range("C" & PassWdRowCount)
Exit Do
End If

PassWdRowCount = PassWdRowCount + 1
Loop
End With

Do While FName <> ""
BookCount = BookCount + 1
ReDim Preserve Bks(BookCount)
Set Bks(BookCount - 1) = _
Workbooks.Open(Filename:=Folder & "\" & FName, _
Password:=BkPassword)
FName = Dir()
Loop
RowCount = RowCount + 1
Loop
End With

Application.Wait "21:00:00"

For i = 0 To (BookCount - 1)
Bks(i).Close savechanges:=False
Next i
End Sub

 

[Joel]

I found a couple of minor problems. Try these updates

Sub openfiles()

Application.Wait "21:00:00"

Dim Bks() As Variant

BookCount = 0
With ThisWorkbook.Sheets("sheet1")
RowCount = 2
Do While .Range("A" & RowCount) <> ""
Folder = .Range("A" & RowCount)
FName = Dir(Folder & "\*.xls")
'get base name of folder
BaseName = Folder
Do While InStr(BaseName, "\") > 0
BaseName = Mid(BaseName, InStr(BaseName, "\") + 1)
Loop

Do While FName <> ""

'get password
With ThisWorkbook.Sheets("PassWd")
'remove xls from filename
BFName = Left(FName, InStr(FName, ".") - 1)
PassWdRowCount = 2
Do While .Range("A" & PassWdRowCount) <> ""
If .Range("B" & PassWdRowCount) = BaseName And _
.Range("A" & PassWdRowCount) = BFName Then

BkPassword = .Range("C" & PassWdRowCount)
Exit Do
End If

PassWdRowCount = PassWdRowCount + 1
Loop
End With

BookCount = BookCount + 1
ReDim Preserve Bks(BookCount)
Set Bks(BookCount - 1) = _
Workbooks.Open(Filename:=Folder & "\" & FName, _
Password:=BkPassword)
FName = Dir()
Loop
RowCount = RowCount + 1
Loop
End With

Application.Wait "22:00:00"

For i = 0 To (BookCount - 1)
Bks(i).Close savechanges:=False
Next i
End Sub

 

[Max]

Many thanks, Joel

Hit a problem initially with the passwords part

Tinkered around, and found that I had to change this line

BFName = Left(FName, InStr(FName, ".") - 1)

to:
BFName = Left(FName, InStr(FName, "_") - 1)

The filenames are like this:
RM01_C001.xls,
RM02_C001.xls
etc

Thereafter your sub ran superbly ..

 

[Max]

Dave, many thanks. Your sub ran marvellous. Superb.

I'll study Chip's link to see how best to incorporate the timing bit into
your sub, albeit Joel has shown how/included the timing bit in his equally
brilliant sub offering.

I'm grateful to both of you for your responses. Thanks.