Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
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 |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
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 |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
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 |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
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 |
#5
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
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 |
#6
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
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 |
#7
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
Thanks Joel for your suggestion, there is no more debugging, but the error
message said " Can not open the file - Existing Macro" then I click OK, nothing happeed. Moreover, can we make it to open several files?, because we want to use the good thing on Getopen file. I do not know why for the non password files, it works perfectly and can open many files and then create the worksheet. Thanks for your more explanation. Frank "joel" wrote: 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 |
#8
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
There are two different type of passwords. An Excel Password and a window
password. I think the password on your file is a window password. I you have an excel password the macro will prompt for a passwrod if you don't have one in the open statement. Try taking the passwrod out of the open statement and see what happens from Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0, _ Password:="topsecret", _ WriteResPassword:="topsecret") to Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0) If yo have a window password the password need to be handled differntly then the code yo present have. If so you will need to go into window explorer and select the file, then right click and select property to find out what windows passwords are set in the file (provided you have thge permission to see the protection). The multiselect option is true on the filedialog box so you can select multiple files. Is ther a different password for differnt files. It isn't clear from your last posting. "Frank Situmorang" wrote: Thanks Joel for your suggestion, there is no more debugging, but the error message said " Can not open the file - Existing Macro" then I click OK, nothing happeed. Moreover, can we make it to open several files?, because we want to use the good thing on Getopen file. I do not know why for the non password files, it works perfectly and can open many files and then create the worksheet. Thanks for your more explanation. Frank "joel" wrote: 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 |
#9
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
Joel,
Mine is excel password and for every ecxel file has the same password. The problem of error message saying " Cannot open file - Existing Macro" still persist. I appreciate your more explanantion. Thanks very much, Frank "joel" wrote: There are two different type of passwords. An Excel Password and a window password. I think the password on your file is a window password. I you have an excel password the macro will prompt for a passwrod if you don't have one in the open statement. Try taking the passwrod out of the open statement and see what happens from Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0, _ Password:="topsecret", _ WriteResPassword:="topsecret") to Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0) If yo have a window password the password need to be handled differntly then the code yo present have. If so you will need to go into window explorer and select the file, then right click and select property to find out what windows passwords are set in the file (provided you have thge permission to see the protection). The multiselect option is true on the filedialog box so you can select multiple files. Is ther a different password for differnt files. It isn't clear from your last posting. "Frank Situmorang" wrote: Thanks Joel for your suggestion, there is no more debugging, but the error message said " Can not open the file - Existing Macro" then I click OK, nothing happeed. Moreover, can we make it to open several files?, because we want to use the good thing on Getopen file. I do not know why for the non password files, it works perfectly and can open many files and then create the worksheet. Thanks for your more explanation. Frank "joel" wrote: 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. |
#10
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
As I said previously you can't circumvent the windows security protection
using VBA. If you can't open the file using a windows explorer you won't be able to open the file from a macro. OPen a window explorer (START - Right Click - Explorer) and find the file. If yo can't see the file then yo don't have protection to open it. If yo can see the file then try to open it and it won't open. Youcan have the owner of the file change the permission to read only so you can open the file. the owner may not have the priviledge and may require an administrator to change the permission. Te protection feature in excel is a 2nd level of prtection after the windows protection is adjusted. "Frank Situmorang" wrote: Joel, Mine is excel password and for every ecxel file has the same password. The problem of error message saying " Cannot open file - Existing Macro" still persist. I appreciate your more explanantion. Thanks very much, Frank "joel" wrote: There are two different type of passwords. An Excel Password and a window password. I think the password on your file is a window password. I you have an excel password the macro will prompt for a passwrod if you don't have one in the open statement. Try taking the passwrod out of the open statement and see what happens from Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0, _ Password:="topsecret", _ WriteResPassword:="topsecret") to Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0) If yo have a window password the password need to be handled differntly then the code yo present have. If so you will need to go into window explorer and select the file, then right click and select property to find out what windows passwords are set in the file (provided you have thge permission to see the protection). The multiselect option is true on the filedialog box so you can select multiple files. Is ther a different password for differnt files. It isn't clear from your last posting. "Frank Situmorang" wrote: Thanks Joel for your suggestion, there is no more debugging, but the error message said " Can not open the file - Existing Macro" then I click OK, nothing happeed. Moreover, can we make it to open several files?, because we want to use the good thing on Getopen file. I do not know why for the non password files, it works perfectly and can open many files and then create the worksheet. Thanks for your more explanation. Frank "joel" wrote: 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: |
#11
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
OK Joel, I reread again your explanation, since wehn we run the macro, it
deos not prompt us to fill in the password, so it must be a window password. How can we we do it I know the password if we open it manually. I appreciate your help. Unfortunately operation people make to kind of folder of their project summary. One folder has files with password and the other folder with password ( the same password for all the files). For each file, every time we open it with Window Explorer it prompt us fo key in the password. Thanks for your kind help. Frank "joel" wrote: As I said previously you can't circumvent the windows security protection using VBA. If you can't open the file using a windows explorer you won't be able to open the file from a macro. OPen a window explorer (START - Right Click - Explorer) and find the file. If yo can't see the file then yo don't have protection to open it. If yo can see the file then try to open it and it won't open. Youcan have the owner of the file change the permission to read only so you can open the file. the owner may not have the priviledge and may require an administrator to change the permission. Te protection feature in excel is a 2nd level of prtection after the windows protection is adjusted. "Frank Situmorang" wrote: Joel, Mine is excel password and for every ecxel file has the same password. The problem of error message saying " Cannot open file - Existing Macro" still persist. I appreciate your more explanantion. Thanks very much, Frank "joel" wrote: There are two different type of passwords. An Excel Password and a window password. I think the password on your file is a window password. I you have an excel password the macro will prompt for a passwrod if you don't have one in the open statement. Try taking the passwrod out of the open statement and see what happens from Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0, _ Password:="topsecret", _ WriteResPassword:="topsecret") to Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0) If yo have a window password the password need to be handled differntly then the code yo present have. If so you will need to go into window explorer and select the file, then right click and select property to find out what windows passwords are set in the file (provided you have thge permission to see the protection). The multiselect option is true on the filedialog box so you can select multiple files. Is ther a different password for differnt files. It isn't clear from your last posting. "Frank Situmorang" wrote: Thanks Joel for your suggestion, there is no more debugging, but the error message said " Can not open the file - Existing Macro" then I click OK, nothing happeed. Moreover, can we make it to open several files?, because we want to use the good thing on Getopen file. I do not know why for the non password files, it works perfectly and can open many files and then create the worksheet. Thanks for your more explanation. Frank "joel" wrote: 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, _ |
#12
Posted to microsoft.public.excel.misc
|
|||
|
|||
GetOpen filename to open files(Workbooks)
I don't know the answer to the problem. You may want to repost the question
asking how to supply a wiondow pasword when opening a workbook using vba. I don't know why the project can't give you read permission to the file that doesn't require a password. Another thing you may tru is performing a query of the file to get the data. Try going to the worksheet an use the following menu Data - Import External Data - New Database Query (or import data). if this works there are other methods to get the data. You can read a workbook without opening the workbook using database access like ADO and DAO. A workbook and an Access database have the same structure. "Frank Situmorang" wrote: OK Joel, I reread again your explanation, since wehn we run the macro, it deos not prompt us to fill in the password, so it must be a window password. How can we we do it I know the password if we open it manually. I appreciate your help. Unfortunately operation people make to kind of folder of their project summary. One folder has files with password and the other folder with password ( the same password for all the files). For each file, every time we open it with Window Explorer it prompt us fo key in the password. Thanks for your kind help. Frank "joel" wrote: As I said previously you can't circumvent the windows security protection using VBA. If you can't open the file using a windows explorer you won't be able to open the file from a macro. OPen a window explorer (START - Right Click - Explorer) and find the file. If yo can't see the file then yo don't have protection to open it. If yo can see the file then try to open it and it won't open. Youcan have the owner of the file change the permission to read only so you can open the file. the owner may not have the priviledge and may require an administrator to change the permission. Te protection feature in excel is a 2nd level of prtection after the windows protection is adjusted. "Frank Situmorang" wrote: Joel, Mine is excel password and for every ecxel file has the same password. The problem of error message saying " Cannot open file - Existing Macro" still persist. I appreciate your more explanantion. Thanks very much, Frank "joel" wrote: There are two different type of passwords. An Excel Password and a window password. I think the password on your file is a window password. I you have an excel password the macro will prompt for a passwrod if you don't have one in the open statement. Try taking the passwrod out of the open statement and see what happens from Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0, _ Password:="topsecret", _ WriteResPassword:="topsecret") to Set FileNameXls = Workbooks.Open( _ Filename:=FName, _ UpdateLinks:=0) If yo have a window password the password need to be handled differntly then the code yo present have. If so you will need to go into window explorer and select the file, then right click and select property to find out what windows passwords are set in the file (provided you have thge permission to see the protection). The multiselect option is true on the filedialog box so you can select multiple files. Is ther a different password for differnt files. It isn't clear from your last posting. "Frank Situmorang" wrote: Thanks Joel for your suggestion, there is no more debugging, but the error message said " Can not open the file - Existing Macro" then I click OK, nothing happeed. Moreover, can we make it to open several files?, because we want to use the good thing on Getopen file. I do not know why for the non password files, it works perfectly and can open many files and then create the worksheet. Thanks for your more explanation. Frank "joel" wrote: 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Workbooks.Open Filename:=.UpdateLinks:=0, IgnoreReadOnlyRecommended:=True | Excel Discussion (Misc queries) | |||
Workbooks.Open Filename | Excel Worksheet Functions | |||
set filename to <filename-date on open | Excel Worksheet Functions | |||
why does excel 2002 add a '1' to the filename everytime I open a f | Excel Discussion (Misc queries) | |||
Global Setting For All Workbooks - Filename In Footer | Excel Worksheet Functions |