I am facing a very weird problem with VBA code. I have an excel file which uses UDFs from an Addin. This file runs on the server so it is really impossible for me to see what actually is going on in the code. Now, whenever I make any changes in the file (on my local machine), I use the local version of the addin. So when replacing the file on the server, I need it to automatically change the links to the addin copy that is there on the server. For this purpose, I have this piece of code in the file:
Private Sub changeLinks(addinName As String, wb As Workbook)
Dim check As Long
Dim i As Long
Dim existingPath As String
Dim correctPath As String
Dim temp As Variant
Dim tempA As Variant
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
temp = getLinks(addinName, wb)
On Error Resume Next
correctPath = Application.AddIns(addinName).fullName
For i = 1 To 100
If temp(i) = "" Then Exit For
If UCase(temp(i)) <> UCase(correctPath) Then
wb.ChangeLink temp(i), correctPath, xlLinkTypeExcelLinks
End If
Next
On Error GoTo 0
End Sub
Private Function getLinks(addinName As String, wb As Workbook)
Dim allLinks As Variant
Dim check As Long
Dim i As Long
Dim temp(1 To 100) As Variant
Dim linkCounts As Long
check = 0
allLinks = wb.LinkSources
linkCounts = 0
On Error Resume Next
For i = LBound(allLinks) To UBound(allLinks)
check = InStr(1, UCase(allLinks(i)), UCase(addinName))
If check <> 0 Then
linkCounts = linkCounts + 1
temp(linkCounts) = allLinks(i)
End If
Next
On Error GoTo 0
getLinks = temp
End Function
In spite of all the statements like Application.DisplayAlerts=False and On Error Resume Next, the code hangs on the line where I use .ChangeLink method. Curiously, the code works ok if I login to the server and run this manually. I believe it is due to some pop-up which appears when the code tries to run .ChangeLink statement. I can't see what this pop-up is, because it runs on the server with a different login. And so now I'm just banging my head to the wall.
Appreciate any help.
Related
I'm writing some VBA to check for changes to a spreadsheet when a button is clicked. The spreadsheet makes a copy of itself in the temp directory as determined by the environment variable on Workbook_Open(). This is all working fine, but the problem is with my button_click sub.
Following advice from this question, I'm trying to read the range of interest into an array. The problem is, my array is coming up empty. Is there something stupid that I'm forgetting to do here?
Dim wsOriginalWS As Worksheet
Dim varOriginalSheet As Variant
Dim wbkOrig As Workbook
Dim strRangeToCheck As String
Dim varOriginalSheet As Variant
'... some other non-relevant things
strRangeToCheck = "A5:HC231"
Set wbkOrig = Workbooks.Open(Filename:=FileStr)
Set wsOriginalWS = wbkOrig.Worksheets("Sheet1")
wsOriginalWS.Activate
With wsOriginalWS
Set varOriginalSheet = Range(strRangeToCheck)
End With
'... some other non-relevant things. At this point,
'... wbkOrig is still open, and I can see it with all of its data
'... while debugging.
itemp = getDimension(varOriginalSheet)
I have verified that everything up to Set varOriginalSheet = Range(strRangeToCheck) is working. The spreadsheet in the temp directory opens and is not empty. For some reason varOriginalSheet is empty.
Here's getDimensions:
Function getDimension(var As Variant) As Long
On Error GoTo Err
Dim i As Long
Dim tmp As Long
i = 0
Do While True
i = i + 1
tmp = UBound(var, i)
Loop
Err:
getDimension = i - 1
End Function
I have password-protected .xls files in a directory. I would like to open each of these files and save them without the password.
However, the files can be opened by using either of the sample passwords listed below.
pwd1 = "123"
pwd2 = "456"
pwd3 = "789"
'Check if pwd1 opens
Application.Workbooks.Open(Filename:=fn, Password:=pwd1)
'If fail then use pwd2
Application.Workbooks.Open(Filename:=fn, Password:=pwd2)
'and so on..
How should I implement this?
Once the file has been opened once, you only need to Unprotect it. This will save a lot of time, instead of constantly opening/closing workbooks.
Here's how I'd do it:
Public Sub CrackWorkbook()
Dim fn As String
fn = "C:\Temp\test_password_is_456.xlsx"
Dim wb As Workbook
Set wb = Workbooks.Open(fn)
Dim lst As Variant
lst = Array("123", "456", "789")
Dim item As Variant
For Each item In lst
On Error GoTo did_not_work
Call wb.Unprotect(item)
Call wb.Save
Call wb.Close(False)
Exit Sub
did_not_work:
On Error GoTo 0
Next item
End Sub
In other words, create an array of strings and do a For Each on them, and set some error-handling to deal with all the failed attempts.
I know GoTo statements are a bit yucky, but that's the best way to handle errors in VBA (as far as I know).
I tried #lebelinoz answer however the routine gives a 1004 error. I googled this behavior and found this post:
https://stackoverflow.com/questions/21176638/vba-how-to-force-ignore-continue-past-1004-error
The code below works by using On Error Resume Next. I based this on #lebelinoz answer.
Public Sub CrackWorkbook()
Dim fn As String
fn = "C:\Temp\test_password_is_456.xlsx"
Dim wb As Workbook
Dim item As Variant
Dim lst As Variant
lst = Array("123", "456", "789")
For Each item In lst
On Error Resume Next
Workbooks.Open Filename:=fn, Password:=item
If Err.Number <> 0 Then GoTo did_not_work:
Exit For
did_not_work:
Next item
Set wb = Activeworkbook
wb.SaveAs Filename:=fn, Password:=""
wb.Close
End Sub
I'm mapping to the company's sharepoint drive using VBA. The intention is to save local file to sharepoint, and delete local file and unmapped the drive after success.
On my machine(Windows 10 64bits), the code works perfectly fine, successfully mapped the drive, created folder and file, successfully uploaded to sharepoint and unmap the drive.
However, when I run the same excel workbook that contains the same code on my colleague's computer(Window 7), it failed. There's no error being shown, except that it keeps on loading and loading until Excel Not Responsive. I tried manually mapping the drive, it success.
I tried to debug and found out that the code stops (keeps on loading) at MsgBox "Hello" but could not figure out what's missing.
Both are using Excel 2016
Any help and suggestions are appreciated. let me know if more info is needed. Thanks in advance.
This is my vba code
Sub imgClicked()
Dim fileName As String
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
Dim objFSO As Object
Dim strMappedDriveLetter As String
Dim strPath As String
Dim spPath As String
strPath = "https://company.com/sites/test/test 123/" 'example path
spPath = AvailableDriveLetter + ":\test.xlsm" 'example path
copyPath = folderPath + "\copyPath\"
'Add reference if missing
Call AddReference
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
strMappedDriveLetter = IsAlreadyMapped(.GetParentFolderName(strPath))
If Not Len(strMappedDriveLetter) > 0 Then
strMappedDriveLetter = AvailableDriveLetter
If Not MapDrive(strMappedDriveLetter, .GetParentFolderName(strPath)) Then
MsgBox "Failed to map SharePoint directory", vbInformation, "Drive Mapping Failure"
Exit Sub
End If
End If
' Check file/folder path If statement here
End With
Set objFSO = Nothing
End Sub
Code for getting available drive
' Returns the available drive letter starting from Z
Public Function AvailableDriveLetter() As String
' Returns the last available (unmapped) drive letter, working backwards from Z:
Dim objFSO As Object
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = Asc("Z") To Asc("A") Step -1
Select Case objFSO.DriveExists(Chr(i))
Case True
Case False
Select Case Chr(i)
Case "C", "D" ' Not actually necessary - .DriveExists should return True anyway...
Case Else
AvailableDriveLetter = Chr(i)
Exit For
End Select
End Select
Next i
Set objFSO = Nothing
MsgBox "This is the next available drive: " + AvailableDriveLetter ' returns Z drive
MsgBox "Hello" ' After this msgBox, starts loading until Not Responsive
End Function
Function to Map drive
Public Function MapDrive(strDriveLetter As String, strDrivePath As String) As Boolean
Dim objNetwork As Object
If Len(IsAlreadyMapped(strDrivePath)) > 0 Then Exit Function
Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive strDriveLetter & ":", strDrivePath, False
MapDrive = True
MsgBox "Successfully Created the Drive!"
Set objNetwork = Nothing
End Function
Code for MappedDrive
Public Function GetMappedDrives() As Variant
' Returns a 2-D array of (1) drive letters and (2) network paths of all mapped drives on the users machine
Dim objFSO As Object
Dim objDrive As Object
Dim arrMappedDrives() As Variant
Dim i As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
ReDim arrMappedDrives(1 To 2, 1 To 1)
For i = Asc("A") To Asc("Z")
If objFSO.DriveExists(Chr(i)) Then
Set objDrive = objFSO.GetDrive(Chr(i))
If Not IsEmpty(arrMappedDrives(1, UBound(arrMappedDrives, 2))) Then
ReDim Preserve arrMappedDrives(1 To 2, 1 To UBound(arrMappedDrives, 2) + 1)
End If
arrMappedDrives(1, UBound(arrMappedDrives, 2)) = Chr(i) ' Could also use objDrive.DriveLetter...
arrMappedDrives(2, UBound(arrMappedDrives, 2)) = objDrive.ShareName
End If
Next i
GetMappedDrives = arrMappedDrives
Set objDrive = Nothing
Set objFSO = Nothing
End Function
Public Function IsAlreadyMapped(strPath As String) As String
' Tests if a given network path is already mapped on the users machine
' (Returns corresponding drive letter or ZLS if not found)
Dim strMappedDrives() As Variant
Dim i As Long
strMappedDrives = GetMappedDrives
For i = LBound(strMappedDrives, 2) To UBound(strMappedDrives, 2)
If LCase(strMappedDrives(2, i)) Like LCase(strPath) Then
IsAlreadyMapped = strMappedDrives(1, i)
Exit For
End If
Next i
Set objNetwork = Nothing
End Function
Add Reference
Sub AddReference()
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
strGUID = "{420B2830-E718-11CF-893D-00A0C9054228}"
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
'Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
'If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
Procedure imgClicked is calling function AvailableDriveLetter multiple times. Remember that the function has to execute each time you refer to it.
I ran imgClicked (assuming that's the procedure you start with) and I was told, twice, "Next available letter = Z" and "Hello" and then it crashed Excel (perhaps getting stuck in a loop of creating FileSystem objects to look for an available drive letter?)
Try assigning AvailableDriveLetter to a variable (string) at the beginning of the procedure and referring to the variable each time you need the value, and see if you still have the issue.
(Remember to save before execution -- I get frustrated when troubleshooting "application hanging" issues because I keep forgetting to save my changes and then lose them on the crash!)
If this doesn't work, add a breakpoint (F9) on the End Function line after your "Hello" box and see if the code stops there. (I have trouble believing the MsgBox or End Function are the culprit.) If not, which procedure runs after that?
One more thing whether the issue is resolved or not:
Add Option Explicit at the very beginning of your module and then Compile the project and fix your missing variable declaration(s).
This is recommended whenever troubleshooting an issue as a means to eliminate variable declaration issues as a possible cause.
I've made a macro to open two workbooks and do some stuff with them. This macro runs from a third workbook that calls any other two user selected workbooks for which, before they're opened, I don't know their name.
So! I know Excel 2010 doesn't have a built in function to check if a workbook is open so, I've been trying to compare the workbook against Nothing but it doesn't work and every workaround I find in different sites tend to use the name of the workbook.
Is there another way of doing this?
The idea is to run a macro with the two user defined workbooks and then, maybe, re-running it in the same workbooks but Excel warms me of discarding changes.
Maybe a workaround could be to tell excel when it prompts for reopening, not to reopen and handle that error to just use the same workbooks, for which at least, I know how part or the names will be. For example, one will have the text "cluster" in it, and the other the word "translation" so, maybe in a loop like the next one, I could find and use the workbook I need but just If I already checked if it's open. Or, does this way works to see if it's opened already?
For each wbk in Application.Workbooks
If wbk.Name Like "*cluster*" Then
WorkingWorkbook = wbk.Name
End If
next
My code is as follows:
Sub structure()
Application.ScreenUpdating = False
Dim translationWorkbook As Worksheet
Dim clusterWorkbook As Workbook
If Not clusterWorkbook Is Nothing Then
Set clusterWorkbook = Application.Workbooks.Open(ThisWorkbook.Sheets(1).Range("E5").Value2)
Else
Set clusterWorkbook = Application.Workbooks(parseFilePath(ThisWorkbook.Sheets(1).Range("E5")))
End If
Set translationWorkbook = Application.Workbooks.Open(ThisWorkbook.Sheets(1).Range("E6").Value2).Worksheets("String_IDs_Cluster") 'Translation table target for completing
End Sub
The parameter passed to Workbooks.Open is the one written in the sheet by my next function:
Private Sub MS_Select_Click()
Dim File As Variant
Dim Filt As String
Filt = "Excel 97-2003 File(*.xls), *.xls," & "Excel File(*.xlsx),*.xlsx," & "Excel Macro File (*.xlsm),*.xlsm"
File = Application.GetOpenFilename(FileFilter:=Filt, FilterIndex:=2, Title:="Select Menu Structure File")
If File = False Or File = "" Then
MsgBox "No File Selected"
Exit Sub
End If
ThisWorkbook.ActiveSheet.Range("E5").Value2 = File
End Sub
Same for translationWorkbook but in a different cell and also, I was trying to create a function to parse and use the filename in a full path(Then I discovered the command Dir lol) but when I pass the filename, without the xls extension to Application.Workbooks(file) it sends me a "subscript range error". Why could that be?
Basically my questions are:
How can I check for an open workbook and use it? Either by handling the
error for excel's prompt or by not trying to reopen the same file.
Why does trying to open a workbook with Application.Workbooks() with the return of my function fails? And here my question splits in two... First: with my function, wouldn't it work if I give a string as an argument? Or maybe, before passing it as an argument, I need to assign the result of my function to a variable?
Second: If I try to open a workbook like this Application.Workbooks("clusterworkbook") it sends me another "subscript error" but, before I used the File Dialog prompt, I made it this way and worked fine.
Any help will be appreciated.
EDIT
Function ParseFilePath added:
Function parseFilePath(fullpath As Range) As String
Dim found As Boolean
Dim contStart As Integer
Dim contEnd As Integer
contEnd = InStr(fullpath, ".") - 1
contStart = contEnd
found = False
Do While found = False
If fullpath.Characters(contStart, 1).Text = "\" Then
found = True
Else
contStart = contStart - 1
End If
Loop
parseFilePath = fullpath.Characters(contStart + 1, (contEnd - contStart)).Text
End Function
How can I check for an open workbook and use it? Either by handling the error for excel's prompt or by not trying to reopen the same file.
Have done some small modifications to your procedure structure. Similar to what you were trying testing for the workbook variable to be nothing, only that you have to first attempt to set the variable, the way you were doing it will always return empty as you did not try to set it before. I have also tested for the translation workbook, as it mightt be open as well.
I'm assuming the values in E5 and E6 contain the FullName of the workbook (i.e. path + filename) and that parseFilePath is a function to extract the filename from the FullName.
Sub structure()
Application.ScreenUpdating = False
Dim clusterWorkbook As Workbook
Dim translationWorkbook As Workbook
Dim translationWorksheet As Worksheet
With ThisWorkbook.Sheets(1)
On Error Resume Next
Set clusterWorkbook = Application.Workbooks(parseFilePath(.Range("E5").Value2))
On Error GoTo 0
If clusterWorkbook Is Nothing Then Set clusterWorkbook = Application.Workbooks.Open(.Range("E5").Value2)
'Set Translation table target for completing
On Error Resume Next
Set translationWorkbook = Application.Workbooks(parseFilePath(.Range("E6").Value2))
On Error GoTo 0
If translationWorkbook Is Nothing Then
Set translationWorksheet = Application.Workbooks.Open(.Range("E6").Value2).Sheets("String_IDs_Cluster")
Else
Set translationWorksheet = translationWorkbook.Sheets("String_IDs_Cluster")
End If
End With
End Sub
Why does trying to open a workbook with Application.Workbooks() with
the return of my function fails? And here my question splits in two...
First: with my function, wouldn't it work if I give a string as an
argument? Or maybe, before passing it as an argument, I need to assign
the result of my function to a variable?
Not sure why it did not work, change the prodedure as indicated.
I tested the procedure above using this function to extract the Filename from the Fullname and it worked:
Function parseFilePath(sFullName As String) As String
parseFilePath = Right(sFullName, Len(sFullName) - InStrRev(sFullName, "\"))
End Function
Second: If I try to open a workbook like this Application.Workbooks("clusterworkbook") it sends me another
"subscript error" but, before I used the File Dialog prompt, I made it
this way and worked fine.
Bear in mind that you did not used that line alone, it most probably has something like:
set Workbook = Application.Workbooks("clusterworkbook")
So the command was to set a variable, not to open the workbook, as such the only situation in which this works is that the workbook is already open so the variable gets set. The times when it failed was when the workbook was not open and you tried to set the variable, given you an error.
Suggest to visit these pages
Excel Objects, On Error Statement
I have been using the below code to identify if the excel workbook is open. If yes, then i activate it and do some stuff. If not, i open it and do some stuff.
sub test()
Dim Ret
Ret = IsWorkBookOpen("Your excel workbook full path")
If Ret = False Then
Workbooks.Open FileName:="Your excel workbook full path", UpdateLinks:=False
Else
Workbooks("Workbook name").Activate
End If
end sub
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
I have the below code it seems to work fine however halfway through it, it stops and restarts when I am debugging the code.
When it restarts is does not show any error message. Does anyone know why my code is doing this?
Sub ExportPICs()
If FileIsOpen("U:\FBS\PROJECTS_TEAM\MI\Sean's Projects\PICS and Benefits\Pics & Benefits upload file.xlsm") Then
MsgBox "That file's open, or doesn't exist - do something else."
Exit Sub
End If
Sheets("Post Implementation Costs").Visible = True
Sheets("Post Implementation Costs").Activate
Sheets("Post Implementation Costs").Unprotect Password:="Projects123"
Dim Tracker As String
Tracker = ThisWorkbook.Name
Dim wkbk As Excel.Workbook
Set wkbk = Workbooks.Open(Filename:= _
"U:\FBS\PROJECTS_TEAM\MI\Sean's Projects\PICS and Benefits\Pics & Benefits upload file.xlsm") '***********CODE RESTARTS HERE WITHOUT ERROR MESSAGE
Dim pics As String
pics = Dir("U:\FBS\PROJECTS_TEAM\MI\Sean's Projects\PICS and Benefits\Pics & Benefits upload file.xlsm")
Workbooks(Tracker).Activate
Sheets("Post Implementation Costs").Activate
Dim rng As Range
Dim CountTrue As Long
Set rng = Range("D16:D100")
CountTrue = Application.WorksheetFunction.CountIf(rng, "PIC")
If CountTrue > 0 Then
Rows("19:" & (CountTrue + 18)).EntireRow.Copy
End If
End Sub
If you have any code in the Workbook Open Event in "Pics & Benefits upload file.xlsm" that would do the Loop.
Try Application.EnableEvents = False
before
Dim wkbk As Excel.Workbook
Set wkbk = Workbooks.Open(Filename:= _
"U:\FBS\PROJECTS_TEAM\MI\Sean's Projects\PICS and Benefits\Pics & Benefits upload file.xlsm")
And after that you can activate it again via Application.EnableEvents = True
This code stops Excel event handlers from being called. Setting it to false is usually done because the effect of the event handler is undesirable or to prevent an infinite loop.
I have discovered too that with some statements the Step command doesn't step but lets all the following code run. To avoid this, set a breakpoint at the line following where the step gets confused.