Hello,

Below VBA works perfectly for non passwords. How can we incorporate
Getopenfile with opening the protoecting workbooks ( all workbooks have the
same password.

The following VBA is debugging at:
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)

This is my whole VBA that I learned from the website of Mr. Ron De Bruin:
Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Thanks a lot in adavance

Frank

The GETOPENFILENAME uses the same function as a window explorer and if the
user doesn't have permissions to get into a folder in the window explorer
then GETOPENFILENAME will not get into the folder. Also if the user can't
open a file in window explorer (even with a password) then they won't be able
to open the file with WORKBOOKS.OPEN. Your code should work the way it is.
You have the pasword included in the WORKBOOKS.OPEN statment. Don't try to
bypas the security features in windows. It won't work.

"Frank Situmorang" wrote:

Hello,

Below VBA works perfectly for non passwords. How can we incorporate
Getopenfile with opening the protoecting workbooks ( all workbooks have the
same password.

The following VBA is debugging at:
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)

This is my whole VBA that I learned from the website of Mr. Ron De Bruin:
Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Thanks a lot in adavance

Frank

Thanks Joel for your response. Could help me to write the VBA?, as you see
below, I tried to write it but it can not work. Could you please edit it?

Thanks

Frank

"joel" wrote:

The GETOPENFILENAME uses the same function as a window explorer and if the
user doesn't have permissions to get into a folder in the window explorer
then GETOPENFILENAME will not get into the folder. Also if the user can't
open a file in window explorer (even with a password) then they won't be able
to open the file with WORKBOOKS.OPEN. Your code should work the way it is.
You have the pasword included in the WORKBOOKS.OPEN statment. Don't try to
bypas the security features in windows. It won't work.

"Frank Situmorang" wrote:

Hello,

Below VBA works perfectly for non passwords. How can we incorporate
Getopenfile with opening the protoecting workbooks ( all workbooks have the
same password.

The following VBA is debugging at:
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)

This is my whole VBA that I learned from the website of Mr. Ron De Bruin:
Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Thanks a lot in adavance

Frank

You had a typeo in the line

Set FileNameXls = Workbooks.Open( _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret")


The format of methods like workbook open has two formats. One without the
equal sign where you don't use parenthesis and one where you have an equal
sign an use parenthesis. You have the equal sign above. Here is theh method
without the equal sign


Workbooks.Open _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret"

The book you open become the active wrokbook so you can add this line now

Set FileNameXls = Activeworkbook


I prefer using the equal sign the way you did. The problem with your
orignal code is you added options after the parenthesis that should of been
inside the parenthesis and yo had an extra closing parenthesis.

"Frank Situmorang" wrote:

Thanks Joel for your response. Could help me to write the VBA?, as you see
below, I tried to write it but it can not work. Could you please edit it?

Thanks

Frank

"joel" wrote:

The GETOPENFILENAME uses the same function as a window explorer and if the
user doesn't have permissions to get into a folder in the window explorer
then GETOPENFILENAME will not get into the folder. Also if the user can't
open a file in window explorer (even with a password) then they won't be able
to open the file with WORKBOOKS.OPEN. Your code should work the way it is.
You have the pasword included in the WORKBOOKS.OPEN statment. Don't try to
bypas the security features in windows. It won't work.

"Frank Situmorang" wrote:

Hello,

Below VBA works perfectly for non passwords. How can we incorporate
Getopenfile with opening the protoecting workbooks ( all workbooks have the
same password.

The following VBA is debugging at:
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)

This is my whole VBA that I learned from the website of Mr. Ron De Bruin:
Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Thanks a lot in adavance

Frank

Hello Joel,

I have added your suggestion but still debugging at your suggetion, could
you please explain more, here is my complete VBA:

Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
Set FileNameXls = Workbooks.Open( _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret")

Set FileNameXls = ActiveWorkbook


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Thanks for your help.

Frank
"joel" wrote:

You had a typeo in the line

Set FileNameXls = Workbooks.Open( _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret")


The format of methods like workbook open has two formats. One without the
equal sign where you don't use parenthesis and one where you have an equal
sign an use parenthesis. You have the equal sign above. Here is theh method
without the equal sign


Workbooks.Open _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret"

The book you open become the active wrokbook so you can add this line now

Set FileNameXls = Activeworkbook


I prefer using the equal sign the way you did. The problem with your
orignal code is you added options after the parenthesis that should of been
inside the parenthesis and yo had an extra closing parenthesis.

"Frank Situmorang" wrote:

Thanks Joel for your response. Could help me to write the VBA?, as you see
below, I tried to write it but it can not work. Could you please edit it?

Thanks

Frank

"joel" wrote:

The GETOPENFILENAME uses the same function as a window explorer and if the
user doesn't have permissions to get into a folder in the window explorer
then GETOPENFILENAME will not get into the folder. Also if the user can't
open a file in window explorer (even with a password) then they won't be able
to open the file with WORKBOOKS.OPEN. Your code should work the way it is.
You have the pasword included in the WORKBOOKS.OPEN statment. Don't try to
bypas the security features in windows. It won't work.

"Frank Situmorang" wrote:

Hello,

Below VBA works perfectly for non passwords. How can we incorporate
Getopenfile with opening the protoecting workbooks ( all workbooks have the
same password.

The following VBA is debugging at:
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)

This is my whole VBA that I learned from the website of Mr. Ron De Bruin:
Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Thanks a lot in adavance

Frank

I did a visula inspection of your code and found lots of errors. the changes
I made should get you past the place where you prevviously had errors. You
where trying to open up an arrays of file names. You need to open ech file
individually.




Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng = Range("C7,C8,E7,D114,H4,D59,E59,D66,F66," & _
"D73,F73,D95,F95,D103,D104") '<----Change


'Select the files with GetOpenFilename
OpenFileName = Application.GetOpenFilename( _
filefilter:="Excel Files,*.xl*", MultiSelect:=True)

If FileNameXls = False Then
MsgBox ("Cannot Open file - Exiting Macro")
Exit Sub
End If

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

If IsArray(FileNameXls) = False Then
'if Only one file selected do nothing
MsgBox ("Only one file selected")
Else

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(xlWBATWorksheet)
'The links to the first workbook will start in row 2
RwNum = 1

For FName = LBound(FileNameXls) To UBound(FileNameXls)

Set FileNameXls = Workbooks.Open( _
Filename:=FName, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret")

ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FName), "\")
JustFileName = Mid(FileNameXls(FName), FinalSlash + 1)
JustFolder = Left(FileNameXls(FName), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute( _
JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & _
ShName & "'!"

MsgBox ("running Macro from workbook : " & PathStr)
On Error Resume Next
SheetCheck = ExecuteExcel4Macro( _
PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook
'the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
FileNameXls.close savechanges:=False
Next FName

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
End If

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub




"Frank Situmorang" wrote:

Hello Joel,

I have added your suggestion but still debugging at your suggetion, could
you please explain more, here is my complete VBA:

Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
Set FileNameXls = Workbooks.Open( _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret")

Set FileNameXls = ActiveWorkbook


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Thanks for your help.

Frank
"joel" wrote:

You had a typeo in the line

Set FileNameXls = Workbooks.Open( _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret")


The format of methods like workbook open has two formats. One without the
equal sign where you don't use parenthesis and one where you have an equal
sign an use parenthesis. You have the equal sign above. Here is theh method
without the equal sign


Workbooks.Open _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
WriteResPassword:="topsecret"

The book you open become the active wrokbook so you can add this line now

Set FileNameXls = Activeworkbook


I prefer using the equal sign the way you did. The problem with your
orignal code is you added options after the parenthesis that should of been
inside the parenthesis and yo had an extra closing parenthesis.

"Frank Situmorang" wrote:

Thanks Joel for your response. Could help me to write the VBA?, as you see
below, I tried to write it but it can not work. Could you please edit it?

Thanks

Frank

"joel" wrote:

The GETOPENFILENAME uses the same function as a window explorer and if the
user doesn't have permissions to get into a folder in the window explorer
then GETOPENFILENAME will not get into the folder. Also if the user can't
open a file in window explorer (even with a password) then they won't be able
to open the file with WORKBOOKS.OPEN. Your code should work the way it is.
You have the pasword included in the WORKBOOKS.OPEN statment. Don't try to
bypas the security features in windows. It won't work.

"Frank Situmorang" wrote:

Hello,

Below VBA works perfectly for non passwords. How can we incorporate
Getopenfile with opening the protoecting workbooks ( all workbooks have the
same password.

The following VBA is debugging at:
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)

This is my whole VBA that I learned from the website of Mr. Ron De Bruin:
Sub Rectangle2_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String

ShName = "SUMMARY" '<---- Change
Set Rng =
Range("C7,C8,E7,D114,H4,D59,E59,D66,F66,D73,F73,D9 5,F95,D103,D104") '<----
Change


'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files,
*.xl*", _
MultiSelect:=True)
'Set FileNameXls = Workbooks.Open(PathStr & FileNameXls),_
'Password:="topsecret", WriteResPassword:="topsecret", UpdateLinks:=0)


If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)

'The links to the first workbook will start in row 2
RwNum = 1

For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName

'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'",
"''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName
& "'!"

On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(,
, xlR1C1))
If Err.Number < 0 Then
'If the sheet not exist in the workbook the row color will
be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum

' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit

MsgBox "The Summary is ready, save the file if you want to keep it"

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Thanks a lot in adavance

Frank