Good Morning everyone,
I am facing a strange Problem in Excel VBA.
So, I have this minimal Example. The only thing it's supposed to do is, add a Button to the Rightklick context menu. This button should then select a cell.
I searched a bit on StackOverflow and found a solution to passing string arguments in .onaction. But then it gets tricky. I can assign a Range and I can Print the Address and the second Argument in a Mesgbox. But I can't set Breakpoints and even stop doesn't work, nor will .select or .ScrollColumn do anything.
To Replicate just copy the Following code into a standard Module and Execute AddContextmenu to add the Button to the Contextmenu.
Option Explicit
Public Sub AddContextmenu()
Dim MySubMenu As CommandBarControl
Dim i As Long
'Clear Previous Menu Items
For Each MySubMenu In Application.CommandBars("Cell").Controls
If Not MySubMenu.BuiltIn Then
MySubMenu.Delete
End If
Next
'add menu
AddScrollButtons Application.CommandBars("Cell"), 1
End Sub
Public Sub AddScrollButtons(ByVal ContextMenu As CommandBar, ByVal baseindex As Long)
Dim cbb As CommandBarButton
Dim sFunction As String
'Add Button
Set cbb = ContextMenu.Controls.Add(Temporary:=True)
With cbb
sFunction = BuildProcArgString("ScrolltoColTest", "$F$10", "TestArg") ' Get Onaction string
.OnAction = sFunction
.Caption = "Scroll Tester"
.Style = msoButtonAutomatic
End With
End Sub
Function BuildProcArgString(ByVal ProcName As String, ParamArray Args() As Variant)
Dim tempArg As Variant
Dim temp As String
For Each tempArg In Args
temp = temp + Chr(34) + tempArg + Chr(34) + ","
Next
BuildProcArgString = "'" & ThisWorkbook.Name & "'!" & ProcName + "(" + Left(temp, Len(temp) - 1) + ")" ' (Workbook has to be included to ensure that the sub will be executed in the correct workbook)
End Function
Public Sub ScrolltoColTest(Addr As String, OtherArg As String)
Dim cell As Range
Set cell = ActiveSheet.Range(Addr) 'Get Cell that sould be selected from Addr
MsgBox cell.Address & vbNewLine & OtherArg 'Test if the Arguments have been passed correctly and the cell has been assigned
Stop 'Why doesn' this stop?
cell.Select 'Why doesn't this do anything
ActiveWindow.ScrollColumn = cell.Column 'Why doesn't this do anything
End Sub
As you will see in ScrolltoColTest the Part after the Msgbox will not work at all.
Does anyone know why that happens?
Related
I have an Excel with two sheets named "Complaints" and "Add Row".
I am using the Add Row sheet to add a row (after the last row with values) to a table named ComplaintsTable in Complaints sheet and I am using a macro paired with a command button to do this.
My code looks like this:
Private Sub CommandButton1_Click()
Dim LastRow As Long, ws As Worksheet, ws1 As Worksheet, newRow As ListRow
Set ws = Sheets("Complaints")
Set ws1 = Sheets("Add Row")
Set tbl = ws.ListObjects("ComplaintsTable")
Set newRow = tbl.ListRows.Add
With newRow
.Range(2) = ws1.Range("C1").Value 'Complaint Yes/No
.Range(12) = ws1.Range("C6").Value 'PCE Yes/No
End With
newRow.Range(4) = ws1.Range("C4").Value 'Subject
newRow.Range(21) = ws1.Range("C5").Value 'Entered Date
'To add Hyperlink
If (ws1.Range("C1").Value = "Yes") Then
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(3), _
Address:=ws1.Range("F3").Value, _
ScreenTip:="Open Complaint in EtQ", _
TextToDisplay:=Worksheets("Add Row").Range("F2").Value
End If
If (ws1.Range("C6").Value = "Yes") Then
'To add hyperlink and PCE Number
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(13), _
Address:=ws1.Range("F8").Value, _
ScreenTip:="Open PCE in EtQ", _
TextToDisplay:=ws1.Range("F7").Value
End If
End Sub
Somehow when I clicked the command button to add values it doesn't add anything! Where am I going wrong?
Here is your refactored, cleaned up code with screenshots. As mentioned by both #Ibo and myself, The problem most likely lies in the fact that you've declared and set newRow as a range but then used it as a property of your table which is impossible.
Option Explicit
Private Sub CommandButton1_Click()
Dim wsComplaints As Worksheet, wsAddRow As Worksheet
Dim tblComplaints As ListObject
Dim lngRows As Long
With ThisWorkbook
Set wsComplaints = .Worksheets("Complaints")
Set wsAddRow = .Worksheets("Add Row")
End With
Set tblComplaints = wsComplaints.ListObjects("ComplaintsTable")
tblComplaints.ListRows.Add
lngRows = tblComplaints.ListRows.Count
With tblComplaints
.DataBodyRange(lngRows, 2) = wsAddRow.Cells(1, 3)
.DataBodyRange(lngRows, 4) = wsAddRow.Cells(4, 3)
.DataBodyRange(lngRows, 12) = wsAddRow.Cells(6, 3)
.DataBodyRange(lngRows, 21) = wsAddRow.Cells(5, 3)
End With
If wsAddRow.Cells(1, 3) = "Yes" Then
tblComplaints.DataBodyRange(lngRows, 3).Hyperlinks.Add _
Anchor:=tblComplaints.DataBodyRange(lngRows, 3), _
Address:=CStr(wsAddRow.Cells(3, 6)), _
ScreenTip:="Open complaint in EtQ", _
TextToDisplay:=CStr(wsAddRow.Cells(2, 6))
End If
If wsAddRow.Cells(6, 3) = "Yes" Then
tblComplaints.DataBodyRange.Hyperlinks.Add _
Anchor:=tblComplaints.DataBodyRange(lngRows, 13), _
Address:=CStr(wsAddRow.Cells(8, 6)), _
ScreenTip:="Open PCE in EtQ", _
TextToDisplay:=CStr(wsAddRow.Cells(7, 6))
End If
End Sub
Screenshots of the solution.
If you click the button and nothing, not even an error of any sort, happens there may be several issues.
To start of with, as mentioned by #Carol, the newRow is not supposed to be qualified by tbl as newRow is not a property or method of tbl
Possibility 1:
You've added a Form Control button to your sheet which you are unable to assign a Private Sub CommandButton1_Click() because, well, it is private and can only be used within the code module it is placed in, it cannot be referenced outside of it.
Possibility 2:
You've added an ActiveX CommandButton, wrote the Private Sub CommandButton1_Click() but then changed the name of the button. In that case, change the CommandButton1 to whatever you've named your button.
Possibility 3:
You've encountered an error, hit debug and the code is paused. As long as the code is paused, no new event will fire and thus your button will appear to do nothing. This is recognized by a line of your code highlighted in yellow. You need to fix the line which caused the error and resume your code by hitting F5 or hitting the stop icon usually located somewhere near the top of your VBA window.
Your text to display must be a zero-length string and that is it is failing to create the hyperlink.
define the text to display like this before to make sure this line is the problem:
myStr=Worksheets("Add Row").Range("F2").Value
Try to define variables and range objects before adding the hyperlink, instead of using the .value etc put them in a string variable and make sure all of them have a valid value. If you try this, it should work, otherwise follow the above instruction and you will find where the problem is:
Replace this block and if it worked, change the other block in the same way:
If (ws1.Range("C1").Value = "Yes") Then
ws.Hyperlinks.Add Anchor:=tbl.newRow.Range(3), _
Address:=ws1.Range("F3").Value, _
ScreenTip:="Open Complaint in EtQ", _
TextToDisplay:=IIf(mystr <> "", mystr, "Click Here")
End If
I have changed the code as follows and it is working perfectly fine without any errors.
Private Sub AddRow_Click()
Dim LastRow As Long, ws As Worksheet, ws1 As Worksheet
Dim newRow As ListRow ', tbl As ListObjects
Dim cmpNo As String, pceNo As String
Set ws = Sheets("Complaints")
Set ws1 = Sheets("AddRow")
Set tbl = ws.ListObjects("ComplaintsTable")
Set newRow = tbl.ListRows.Add
With newRow
.Range(1) = ws1.Range("C1").Value 'Complaint Yes/No
.Range(11) = ws1.Range("C6").Value 'PCE Yes/No
.Range(3) = ws1.Range("C4").Value 'Subject
.Range(20) = ws1.Range("C5").Value 'Entered Date
End With
'To add Hyperlink
If (ws1.Range("C1").Value = "Yes") Then
Call ActiveSheet.Hyperlinks.Add(newRow.Range(2), ws1.Range("F3").Value, "", "Open in EtQ", ws1.Range("F2").Value)
End If
If (ws1.Range("C6").Value = "Yes") Then
Call ActiveSheet.Hyperlinks.Add(newRow.Range(12), ws1.Range("F8").Value, "", "Open in EtQ", ws1.Range("F7").Value)
'To add hyperlink and PCE Number
End If
End Sub
The problem with the code is that "newRow.Range" does not work with the " hyperlinks.add". I fugered out this a few days ago but I didn't get a chance to post this.
I appreciate all your help!
I am using the following vba code in a workbook open event:
Private Sub Workbook_Open()
On Error GoTo Message
Application.AskToUpdateLinks = False
ThisWorkbook.UpdateLinks = xlUpdateLinksNever
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim currentTime As Date
currentTime = DateAdd("s", 10, Now)
Call CurUserNames
Application.OnTime currentTime, "SaveFile"
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
I also have this code in a module:
Public Sub SaveFile()
On Error GoTo Message
ThisWorkbook.Save
Dim currentTime As Date
currentTime = DateAdd("s", 10, Now)
Application.OnTime currentTime, "SaveFile"
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
What I am trying to do is automatically save my workbook every 10 seconds.
This works.
However, something quite annoying I've noticed happens. If a user has this workbook open in the background and is working on another excel workbook then this workbook will activate and display on top of the other workbook when saving.
This can be quite annoying for the user.
Is there a way I can get my workbook to save without activating the workbook?
P.S:
For some unknown reason, this also causes the workbook to reopen when its been closed.
EDIT:
List active users in workbook code:
Sub CurUserNames()
Dim str As String
Dim Val1 As String
str = "Users currently online:" & Chr(10)
For i = 1 To UBound(ThisWorkbook.UserStatus)
str = str & ThisWorkbook.UserStatus(i, 1) & ", "
Next
Val1 = DeDupeString(Mid(str, 1, Len(str) - 2))
Worksheets("Delivery Tracking").Range("F4").Value = Val1
End Sub
Function DeDupeString(ByVal sInput As String, Optional ByVal sDelimiter As String = ",") As String
Dim varSection As Variant
Dim sTemp As String
For Each varSection In Split(sInput, sDelimiter)
If InStr(1, sDelimiter & sTemp & sDelimiter, sDelimiter & varSection & sDelimiter, vbTextCompare) = 0 Then
sTemp = sTemp & sDelimiter & varSection
End If
Next varSection
DeDupeString = Mid(sTemp, Len(sDelimiter) + 1)
End Function
Users of a shared workbook can see Who has this workbook open now: just by going to the Review tab in the Ribbon and click the Shared Workbook icon in the Changes group. This will open the Shared Workbook dialog box, in it the tab Editing' shows *Who has this workbook open now:`*. Additionally the tab 'Advance' can be used to update the settings dealing with:
Track changes
Update changes
Conflicting changes between users
Include in personal view
Th9is example comes from How can I get list of users using specific shared workbook?
It is a little overkill. It creates a new workbook to put the users name in. But you can modify it to put the names in whatever sheet and whatever cells you want.
Put it in the sheet module under the selection change module. Then it will update every time the user moves to a different cell. If it is open and he's not at his desk - it doesn't do anything.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
At the bottom is the code from the above link that you can modify to suit your own needs. It will be 1000 times better than saving a workbook every ten seconds. Which can actually take 3 or 4 seconds itself.
If you don't want to use selection change in the worksheet module then you could put your code into the workbook module Private Sub Workbook_Open()
and put it on a timer to run every 10 seconds. It will only take a fraction of a second instead of several seconds.
users = ActiveWorkbook.UserStatus
With Workbooks.Add.Sheets(1)
For row = 1 To UBound(users, 1)
.Cells(row, 1) = users(row, 1)
.Cells(row, 2) = users(row, 2)
Select Case users(row, 3)
Case 1
.Cells(row, 3).Value = "Exclusive"
Case 2
.Cells(row, 3).Value = "Shared"
End Select
Next
End With
I want when I click the button "Sélectionner un poste" it will tell me the position. (The button which I clicked in which row.)
Code to create the button:
Sub AjouterBoutonPoste(positionX As Integer, positionY As Integer, nom As String)
Set t = ActiveSheet.Range(Cells(positionX, positionY), Cells(positionX, positionY))
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
With btn
.OnAction = "PosteBtAction"
.Caption = "Sélectionner un poste"
.Name = nom & CStr(positionX) & CStr(positionY)
End With
End Sub
Code for the event button:
Sub PosteBtAction()
AssocierSessoinCandidature.Show
End Sub
I have an application window named AssocierSessoinCandidature. I want the position which I clicked sent to the application window.
Here is my example Excel sheet:
Call the below Sub when the button is clicked
Sub foo()
Dim obj As Object
Dim row_no As Integer
Set obj = ActiveSheet.Buttons(Application.Caller)
With obj.TopLeftCell
row_no = .Row
End With
MsgBox "The Button is in the row number " & row_no
End Sub
You can access properties of the Button object for TopLeftCell and BottomRightCell to get the range addresses that bound the control:
Option Explicit
Sub Test()
Dim ws As Worksheet
Dim btn As Object
Dim strAddressTopLeft As String
Dim strAddressBottomRight As String
Dim strButtonName As String
Set ws = ActiveSheet
For Each btn In ws.Buttons
strAddressTopLeft = btn.TopLeftCell.Address
strAddressBottomRight = btn.BottomRightCell.Address
strButtonName = btn.Name
Debug.Print "Range of button (" & strButtonName & "): " & _
strAddressTopLeft & ":" & _
strAddressBottomRight
Next btn
End Sub
I have used something very similar, you can adapt the below code:
Sub Button24_Click()
Dim strShape As String
strShape = Shapes("button24").TopLeftCell.Address
CallAnotherFunction strShape
End Sub
Upon clicking the button, this code will take the range of button24 as a string (not sure why I didn't use a range, you could if you wish) and pass it to the function CallAnotherFunction
In summary, this is what you need:
Shapes("button24").TopLeftCell.Address
or
Shapes("button24").TopLeftCell.Row
I am trying to send out an email with updates when the the sheet are saved. To do this I am tracking changes and then trying to save these changes as a global string:
Public outString As String
Public Sub Worksheet_Change(ByVal Target As Range)
Dim colN, rowN As Integer
Dim changeHeading As String
Dim drawingNumber, partNumber As Integer
'Do nothing if more than one cell is changed or content deleted
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
'Stop any possible runtime errors and halting code
On Error Resume Next
Application.EnableEvents = False
colN = Target.Column
rowN = Target.Row
changeHeading = ThisWorkbook.Sheets("List").Cells(1, colN).Value 'Header of the changed cell
partNumber = ThisWorkbook.Sheets("List").Cells(rowN, 2).Value 'Partnumber changed
drawingNumber = ThisWorkbook.Sheets("List").Cells(rowN, 4).Value 'Drawingnumber changed
outString = outString & vbNewLine _
& "PartNumber: " & partNumber & " DrawingNumber: " & drawingNumber _
& " " & changeHeading & ": " & Target & vbNewLine
'Turn events back on
Application.EnableEvents = True
'Allow run time errors again
On Error GoTo 0
End Sub
So this piece of code works nice except if I alter several column on the same row then each change will be presented on a new line instead of the same line, Maybe i have to use a dictionary with partnumber as key to avoid this.
Then in thisworkbook sheet i have the following code
Public outString
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call track
Call missingDrawings
Call updateText
End Sub
However now the outString variable is , so what did I do wrong when declaring the global variable outString?
You seem to have two variables called outString one in the worksheet and one in the workbook. You should only have one. If you leave the one in thisWorkbook (adding As String would be a good idea), then you can access it from the sheet by using ThisWorkbook.outString.
I am trying to use VBA to open hyperlinks from my excel using the following code:
numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
ActiveSheet.Range("E" & numRow).Hyperlinks(1).Follow
numRow = numRow + 1
Loop
However, I keep getting Runtime Error 9: Subscript out of range at the point in the code where I follow the hyperlinks.
I'm pretty new to VBA Macro-making (as in-'never done it before'), so help would be appreciated. (And if there's a better way to open a link from each cell in a single column, I'd appreciate learning about that too)
EDIT (To add more Info)
The hyperlink in question has been created using HYPERLINK Worksheet function and the text does not display the link URL. Sample of worksheet data is something like this:
What It Looks Like
Case ------ Link
Case1----- Summary
Case2----- Summary
Case3----- Summary
The Cells showing the text "Summary", however, contain a formula
=HYPERLINK("whateverthebaseurlis/"&[#[Case]]&"/Summary", "Summary")
And this is the link that has to be followed. The link works, it can be followed manually. But I need to do it via macro
Thanks
Probably, you are getting error because you have some cells with text but no link!
Check for link instead of whether or not cell is text:
numRow = 1
Do While ActiveSheet.Range("E" & numRow).Hyperlinks.Count > 0
ActiveSheet.Range("E" & numRow).Hyperlinks(1).Follow
numRow = numRow + 1
Loop
If it is throwing the error where you try to open hyperlinks, try and explictly open it using explorer.exe
Shell "explorer.exe " & Range("E" & numRow).Text
the reason Hyperlinks(1).Follow not working is that is no conventional hyperlink in the cell so it will return out of range
numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
URL = Range("E" & numRow).Text
Shell "C:\Program Files\Internet Explorer\iexplore.exe " & URL, vbNormalNoFocus
numRow = numRow + 1
Loop
Check this post for a similar problem:
http://www.mrexcel.com/forum/excel-questions/381291-activating-hyperlinks-via-visual-basic-applications.html
TRIED AND TESTED
Assumptions
I am covering 3 scenarios here as shown in the Excel file.
=HYPERLINK("www."&"Google"&".Com","Google"). This hyperlink has a friendly name
www.Google.com Normal hyperlink
=HYPERLINK("www."&"Google"&".Com") This hyperlink doesn't have a friendly name
Screenshot:
Logic:
Check what kind of hyperlink is it. If it is other than which has a friendly name then the code is pretty straightforward
If the hyperlink has a friendly name then what the code tries to do is extract the text "www."&"Google"&".Com" from =HYPERLINK("www."&"Google"&".Com","Google") and then store it as a formula in that cell
Once the formula converts the above text to a normal hyperlink i.e without the friendly name then we open it using ShellExecute
Reset the cell's original formula
Code:
Private Declare Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal Operation As String, _
ByVal Filename As String, Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As Long
Sub Sample()
Dim sFormula As String
Dim sTmp1 As String, sTmp2 As String
Dim i As Long
Dim ws As Worksheet
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets(1)
i = 1
With ActiveSheet
Do While WorksheetFunction.IsText(.Range("E" & i))
With .Range("E" & i)
'~~> Store the cells formula in a variable for future use
sFormula = .Formula
'~~> Check if cell has a normal hyperlink like as shown in E2
If .Hyperlinks.Count > 0 Then
.Hyperlinks(1).Follow
'~~> Check if the cell has a hyperlink created using =HYPERLINK()
ElseIf InStr(1, sFormula, "=HYPERLINK(") Then
'~~> Check if it has a friendly name
If InStr(1, sFormula, ",") Then
'
' The idea here is to retrieve "www."&"Google"&".Com"
' from =HYPERLINK("www."&"Google"&".Com","Google")
' and then store it as a formula in that cell
'
sTmp1 = Split(sFormula, ",")(0)
sTmp2 = "=" & Split(sTmp1, "HYPERLINK(")(1)
.Formula = sTmp2
ShellExecute 0, "Open", .Text
'~~> Reset the formula
.Formula = sFormula
'~~> If it doesn't have a friendly name
Else
ShellExecute 0, "Open", .Text
End If
End If
End With
i = i + 1
Loop
End With
End Sub
A cleaner way of getting cells hyperlinks:
Using Range.Value(xlRangeValueXMLSpreadsheet), one can get cell hyperlink in XML. As so, we only have to parse XML.
'Add reference to Microsoft XML (MSXML#.DLL)
Function GetHyperlinks(ByVal Range As Range) As Collection
Dim ret As New Collection, h As IXMLDOMAttribute
Set GetHyperlinks = ret
With New DOMDocument
.async = False
Call .LoadXML(Range.Value(xlRangeValueXMLSpreadsheet))
For Each h In .SelectNodes("//#ss:HRef")
ret.Add h.Value
Next
End With
End Function
So you can use this function in your code as this:
numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
FollowHyperlink GetHyperlinks(ActiveSheet.Range("E" & numRow))
numRow = numRow + 1
Loop
If you don't need numRow, you can just:
Dim h as String
For Each h In GetHyperlinks(ActiveSheet.Range("E:E"))
FollowHyperlink h
Next
For FollowHyperlink, I suggest below code - you have other options from another answers:
Sub FollowHyperlink(ByVal URL As String)
Shell Shell "CMD.EXE /C START """" """ & URL & """"
End Sub