copy a range from closed workbooks

[Louise]

I am trying to copy a range from several closed and password protected workbooks. I have 2 problems:
1) I have not been able to unprotect the workbooks automatically
Using the ActiveWorkbook.Unprotect (MyPassword) does not work
2) I want to be able to tie the file names to a cell in the basebook

Where the code reads: If Left(FNames, 4) = "YEAR" Then
I need to replace the "YEAR" for Cell C3 in the basebook.

Following is the code that I am using.

Thanks in advance for the help!
Louise

------------------------------
Sub CopyRangesOfClosedWorkbooks()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim subfolder As String

SaveDriveDir = CurDir
MyPath = Range("A1")

ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")

If Len(FNames) = 0 Then

MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir

Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook

basebook.Worksheets(2).Cells.Clear
'clear all cells on the second sheet
rnum = 1

Do While FNames <> ""

If Left(FNames, 4) = "YEAR" Then

Set mybook = Workbooks.Open(FNames)



Set sourceRange = mybook.Worksheets("1").Range("c30:c32")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(2).Cells(rnum, 1)

basebook.Worksheets(2).Cells(rnum, "D").Value = mybook.Name
'This will add the workbook name in column D if you want

With sourceRange
Set destrange = basebook.Worksheets(2).Cells(rnum, "A").Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
mybook.Close False
End If


FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

 

[Ron de Bruin]

Good morning

Try this

' cell on the first sheet
If Left(FNames, 4) = basebook.Worksheets(1).range("A1").Value Then

Set mybook = Workbooks.Open(Filename:=FNames, Password:="ron")

 

[Louise]

Good morning, Ron, your code is wonderful! Thanks!
The password solution worked. However, it is still not picking up
the value from Cell "A1". Any other ideas? I DO really appreciate your
help!

Louise

 

[Ron de Bruin]

Hi Louise

Is the cell that you want to use in the first sheet of the baseworkbook?
I use the index in the code but you can also use

basebook.Worksheets("YourSheetName").range("A1").value

 

[Louise]

Yes, it is. I have not renamed the sheet. It is "Sheet 1"

 

[Ron de Bruin]

Send me a copy of your workbook (private) and i will take a look

 

[Louise]

I appreciate your offer. At this point, as I am testing the code,
I am just using a blank workbook with 2004 on Cell A1,
Sheet 1, and MyPath on Cell B1.
Your code works perfect retrieving info from all other workbooks
that begin with 2004, if I use If Left(FNames, 4) = "2004" Then
However, if I replace the "2004" with the
basebook.Worksheets(1).range("A1").value
it does not do a thing.

Again, the code that I have on that blank workbook is:

Sub CopyRangesOfClosedWorkbooks()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim subfolder As String


SaveDriveDir = CurDir
MyPath = Range("b1")

ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")

If Len(FNames) = 0 Then

MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir

Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook

basebook.Worksheets(2).Cells.Clear
'clear all cells on the second sheet
rnum = 1
Do While FNames <> ""

If Left(FNames, 4) = basebook.Worksheets(1).Range("A1").Value Then

Set mybook = Workbooks.Open(Filename:=FNames, Password:="mypassword")


Set sourceRange = mybook.Worksheets("MyWorksheet").Range("c30:c32")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(2).Cells(rnum, 1)

basebook.Worksheets(2).Cells(rnum, "D").Value = mybook.Name
'This will add the workbook name in column D if you want

With sourceRange
Set destrange = basebook.Worksheets(2).Cells(rnum, "A").Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
mybook.Close False
End If
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub





I should, but it does not.

 

[Ron de Bruin]

See answer in private Mail