Remove known password from directory of Excel files with VBA - excel

I have found this VBA code and it works to remove the known password on one Excel workbook just fine.
Sub testPasswordRemoval()
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:="C:\Temp\Book2.xlsm", Password:="pw")
wb.Password = ""
wb.SaveAs "C:\Temp\NewBook.xlsm"
End Sub
But, I have tried various tutorials and videos (many folks offering this) but none of them work to loop through a folder of .xlsx files (all with the same known password) and remove that same password.
I am not a VBA person, but have spent about 16 hours over the past three days trying to crack the code on this one. I have found several examples of looping over files in a directory, but none that enabled me to put the above code into them and loop and remove passwords.

Try this code, read the comments, and adjust it to fit your needs
Code:
Public Sub RemovePassLoopThroughFiles()
Dim targetWorkbook As Workbook
Dim filePath As String
Dim folderPath As String
Dim folderWildcard As String
Dim currentFileName As String
Dim currentFileExtension As String
Dim newFileName As String
Dim newfileNameSuffix As String
Dim currentPassword As String
Dim newPassword As String
' Adjust next lines to fit your needs
folderPath = "C:\Temp\" ' With slash at the end
folderWildcard = "*.xls*" ' You can change the suffix to open specific files
newfileNameSuffix = "_NoPassword"
currentPassword = "pw"
newPassword = ""
' Get the file path concat folder and wildcards
filePath = Dir(folderPath & folderWildcard)
Do While Len(filePath) > 0
' Open the workbook and set reference
Set targetWorkbook = Workbooks.Open(Filename:=filePath, Password:=currentPassword)
' Get current file extension
currentFileExtension = Right(filePath, Len(filePath) - InStrRev(filePath, "."))
' Get filename no extension
currentFileName = Left(filePath, InStrRev(filePath, ".") - 1)
' Build new fileName
newFileName = currentFileName & newfileNameSuffix & "." & currentFileExtension
' Set new password
targetWorkbook.Password = newPassword
' Save new file
targetWorkbook.SaveAs folderPath & newFileName
'Debug.Print filePath
filePath = Dir
targetWorkbook.Close True
Set targetWorkbook = Nothing
Loop
End Sub
Let me know if it works.

Related

Looping code error-Excel says that it can't find the file

I'm trying to write a code that will refresh all workbooks starting with 'FY' in a folder. With the current code, the first two workbooks refresh, but when it comes to the third workbook, I get this error:
Sorry, we couldn't find FY20 11-15.xlsm\FY20 1-5.xlsm. Is it possible it was moved, renamed or deleted?"
The path to the workbook is "C:\Documents\Database\Sales".
Here's the code:
Sub refreshdata()
Dim file As String
Dim book As String
file = Application.ThisWorkbook.Path
book = Dir(file & "\FY*.xlsm")
Do While file <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(file & "\" & book)
Call Refresh
wb.Close savechanges:=True
file = Dir
Loop
End Sub
You named your variables not clearly and file contains actually a path file = Application.ThisWorkbook.Path therefore you mixed everything up. Get your variable names more meaningful! Make sure your variables are well named after what content they contain or you confuse yourself.
Sub refreshdata()
Dim Path As String
Path = Application.ThisWorkbook.Path
Dim FileName As String
FileName = Dir(Path & "\FY*.xlsm")
Do While FileName <> vbNullString
Dim wb As Workbook
Set wb = Workbooks.Open(Path & "\" & FileName)
Call Refresh
wb.Close SaveChanges:=True
FileName = Dir
Loop
End Sub
What was wrong?
Here file = Dir you set your file variable which actually was the path to filename. And in the next iteration of the loop Set wb = Workbooks.Open(file & "\" & book) is twice a filename, the new filename in file and the old in book.

Open file which do not have standard name

Suppose, we have one folder with only one macro file and every day we are saving excel file in the same folder received via mail. However, filename every day will get changed. I mean to say what ever file we are getting through mail do not have a standard name. Now, we have two files in the same folder.
Can we open another file which we have saved with some random name available in the same folder using a macro? Here, the name of another file is not standard. Additionally, after running a macro, we also want to delete that file.
You can get the filename of the newest file within a directory by this:
Option Explicit
Private Sub GetNewestFilename()
Dim searchDirectory As String
Dim searchPattern As String
Dim currentFilename As String
Dim NewestFilename As String
Dim NewestFiledate As Date
searchDirectory = Application.DefaultFilePath & "\"
searchPattern = "*.xl*"
currentFilename = Dir(searchDirectory & searchPattern, 0)
If currentFilename <> "" Then
NewestFilename = currentFilename
NewestFiledate = FileDateTime(searchDirectory & currentFilename)
Do While currentFilename <> ""
If FileDateTime(searchDirectory & currentFilename) > NewestFiledate Then
NewestFilename = currentFilename
NewestFiledate = FileDateTime(searchDirectory & currentFilename)
End If
currentFilename = Dir
Loop
End If
MsgBox NewestFilename
Dim wb As Workbook
Set wb = Workbooks.Open(searchDirectory & NewestFilename)
' do something
wb.Close SaveChanges:=False
Set wb = Nothing
' Kill searchDirectory & NewestFilename ' Delete the file
End Sub

Excel VBA: Copy data from multiple passwordprotected workbooks in a folder into one worksheet in another workboo

I have written a code that opens a password protected workbook in a folder, copy some values out of it and paste the values in active woorkbook. This works fine.
My problem is that I have 16 password protected files in this folder, and I need a loop that does the same thing with every file. Below you can find the code, and I think all my problems should be properly explained with comments inside the code. Please ask if anything is unclear. In advance, thanks for any help!
Code:
Sub Bengt()
Dim sPath As String
Dim vFolder As Variant
Dim sFile As String
Dim sDataRange As String
Dim mydata As String
Dim wb As Workbook
Dim WBookOther As Workbook
Dim myArray As Variant '<<does the list of passwords have to be array?
sPath = ThisWorkbook.Path & Application.PathSeparator
sDataRange = "Budsjett_resultat'!E2" '<<every file I want to open has data in this sheet and range
sFile = "BENGT.xlsm" '<< how to make sFile be every file in folder?
' here I want a loop that opens every woorkbook in the folder M::\SALG\2016\Budsjett\
Set WBookOther = Workbooks.Open(sPath & sFile, Password:="bengt123")
' all passwords starts with filename + three numbers after as you can see
' here I want to make excel find the password out of a list of passwords in range B100:B116
mydata = "='" & sPath & "[" & sFile & "]" & sDataRange
'mydata = "='M:\SALG\2016\Budsjett\Bengt.xlsmBudsjett_resultat'!E2:E54" '<< change as required
'link to worksheet
With ThisWorkbook.Worksheets(1).Range("T2:T54")
'in this case I want the loop to find "BENGT"(which is the filename) in cell T1, and paste the values in range T2:T54.
'For the other files, I want the loop to find the filename (of the file it opened) in row 1,
'and paste the values in range ?2-?54 at the column with the same name as the filename
.Formula = mydata
.Value = .Value
WBookOther.Close SaveChanges:=False
End With
End Sub
For the password array I have tried following code:
Sub passord()
Dim myArray As Variant
myArray = ThisWorkbook.Worksheets(1).Range("B100:B116")
On Error Resume Next 'turn error reporting off
For i = LBound(myArray, 1) To UBound(myArray, 1)
Set wb = Workbooks.Open("M:\SALG\2016\Budsjett\BENGT.xlsm", Password:=myArray(i, 1))
If Not wb Is Nothing Then bOpen = True: Exit For
Next i
End Sub
I have tried to implement the last sub into the first sub, but I can't figure out how to make it work.

Excel VBA File not Found although file exists

I have written below piece of code to access a file and copy content from one file to the other. I am using excel 2007.
Sub copypaste()
Dim strFolder As String
Dim strFileName As String
Dim wb As Workbook
strFolder = "C:\Users\user\Desktop\sample\"
strFileName = Dir(strFolder & "*.xlsx")
Dim eRow
Dim a As Variant
Dim b As Variant
Do While Len(strFileName) > 0
**Set wb = Workbooks.Open(strFileName)**
a = Cells(7, 7)
b = Range("D11:F11")
ActiveWorkbook.Close
Worksheets("sheet1").Cells(7, 7) = a
Worksheets("sheet1").Cells(7, 8) = b
strFileName = Dir
Loop
End Sub
Although the file exists in the folder I get the error while opening the file. While in debug mode the variable strFileName contains the file name but still the file is not opening. I am getting the error at line "Set wb = Workbooks.Open(strFileName)"
Thanks in advance for your help!!
Workbooks.Open requires the full path to the workbook. I suspect you want:
Set wb = Workbooks.Open(strFolder & strFileName)
You need to replace all \ by double \\ in your path
Or add # in front of you string.
It is cause \ is the character for escape strings, like \n \s and so on so letter after a \ is transformed.
Try to print your path, you'll see what append.
EDIT
May also try :
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.xls (*.xls),");
Set wb2 = Workbooks.Open(Filename:=FileToOpen)
As (gone) user user496736 stated you need to have a full path
But most of the time your path will be very long and cumbersome to type or you will not know it in advance, so the help of ActiveWorkbook.Path
Exemple with readonly just for information
Dim Alloc_WB As Workbook
Dim FileStr As String
FileStr = ActiveWorkbook.Path & "\" & "my_file.xlsx"
'workbook should be closed at start of code. Otherwise you get an error msg asking to re-open the Workbook
Set Alloc_WB = Workbooks.Open(Filename:=FileStr, ReadOnly:=True)
'...
'Other actions here...
'...
With Alloc_WB
.Close
End With

How to get the path of current worksheet in VBA?

I wrote a macro as an add-in, and I need to get the path of the current worksheet on which it is being executed. How do I do this? How do I get the file path (just the directory)?
Use Application.ActiveWorkbook.Path for just the path itself (without the workbook name) or Application.ActiveWorkbook.FullName for the path with the workbook name.
Always nice to have:
Dim myPath As String
Dim folderPath As String
folderPath = Application.ActiveWorkbook.Path
myPath = Application.ActiveWorkbook.FullName
If you want to get the path of the workbook from where the macro is being executed - use
Application.ThisWorkbook.Path
Application.ActiveWorkbook.Path can sometimes produce unexpected results (e.g. if your macro switches between multiple workbooks).
The quickest way
path = ThisWorkbook.Path & "\"
I had the same problem and I built a solution that I'm going to share. Below is the function in VBA for Excel GetLocalPath(), which gets the local path of the ActiveWorkbook:
`Function GetLocalPath() As String
Dim sRowPath As String
Dim sLocalPath As String
Dim iFindhttp As Integer
sRowPath = Application.ActiveWorkbook.Path
If LCase(Left(sRowPath, 4)) = "http" Then
Dim fso As New FileSystemObject
sLocalPath = fso.GetAbsolutePathName(sRowPath)
iFindhttp = InStr(LCase(sLocalPath), "\http")
sLocalPath = Left(sLocalPath, iFindhttp - 1)
Set fso = Nothing
Else
sLocalPath = sRowPath
End If
GetLocalPath = sLocalPath
End Function`

Resources