What is the VBA to put the password in the prompted box

[Frank Situmorang]

Hello,

When we run the following VBA to open the password protected workbooks, it
will prompt us to fill in the password.

FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)

I appreciate if some one can tell me the VBA to fill in the password box.

Thanks in advance

Frank

 

[Dave Peterson]

There is no command that will do this for you.

You either need to supply it in your code on the workbooks.open() line (and that
means you have to know the password for each of the files selected)

or

You have to let the user type it in.

 

[Frank Situmorang]

Dave as you see my VBA in other postings, I have supplies the password in the
Getopen filename, but it does not work.

Could you help me how can we write it, what is wrong with my VBA

Thanks

Frank

 

[Dave Peterson]

You've posted variations of this same questions a lot of times. I don't know
where the current thread is or what the current code looks like to change it.

 

[Frank Situmorang]

Dave:

It is debugging at:
Set FileNameXls = Workbooks.Open( _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
----> WriteResPassword:="topsecret")

Below is my complete current code :

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,D118,H5,D63,E63,D70,F70,D80,F80,D102,F102,D108,D109")
'<---- 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:="KIKI", _
WriteResPassword:="KIKI")

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

 

[Dave Peterson]

You have a response (not from me) at one of your other threads.

Dave:

It is debugging at:
Set FileNameXls = Workbooks.Open( _
Filename:=PathStr & FileNameXls, _
UpdateLinks:=0, _
Password:="topsecret", _
----> WriteResPassword:="topsecret")

Below is my complete current code :

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,D118,H5,D63,E63,D70,F70,D80,F80,D102,F102,D108,D109")
'<---- 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:="KIKI", _
WriteResPassword:="KIKI")

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