I'm trying to retrieve the sheet reference location from a hyperlink that's in a cell
The following doesn't seem to work as test doesn't return anything, even though G8 points to Sheet: KO in Cell A19
test = Range("G8").Hyperlinks(3).Address
Now if I run the following:
For Each hl In Sheets("LIST").Hyperlinks
MsgBox "Range " & hl.Range.Address & " addr " & _
hl.Address & " text " & hl.TextToDisplay
Next hl
It cycles through and finds the correct address but I can't seem to work out how to detect the sheet it's pointing. Also the loop is a bit of a mess because it errors out once it has found the first and only hyperlink in this situation. And it's not always specific for G8. I guess I could just throw an if statement in and exit the for loop early.
Regardless of that, I can't find anywhere in stackoverflow, google, microsofts "hyperlinks" docs a way to get the sheet name.
See below sample illustration:
SubAddress is what you want:
Sub Test()
Dim hl As Hyperlink, r As Range
Set hl = ActiveSheet.Hyperlinks(1)
Set r = Application.Evaluate(hl.SubAddress)
Debug.Print "Sheet: '" & r.Parent.Name & "'", "Range:" & r.Address()
End Sub
Related
I have a workbook that is essentially an automated test, marking and feedback tool for end of topic tests for students. On the '701Test' sheetThey input their teaching group via a drop down list and the select their from subsequent list. They answer the multiple choice questions and press a button when finished. The button takes them to a 'results' page which gives their marks for each question, give feedback for incorrect answers and gives a total score. They then hit the finish button which generates a PDF copy of the mark sheet in their my documents folder and then emails a copy to themselves and the Schools email account. At this point I also wanted to post the final score to the students record on a central registry using a loop through the student list to find the name and offset to post the Score value from the 'Results' page and finally return to the test page. This last bit I wrote the code for in a module and it executes perfectly, but when added to the main code and run from the button the loop part fails to execute but the return to the test page does work, but no error is recorded for the loop failure.
Here is the 'Results' page code in full the 'With Central reg' bit at the bottom is the problem, any help is greatly appreciated.
Private Sub CommandButton1_Click()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim cell As Range
Dim Students As Range
Title = Range("D1").Value
sname = Range("B2").Value
PdfFile = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & sname & Title & ".pdf"
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
With OutlApp.CreateItem(0)
.Subject = Title
.to = Range("B2").Value ' <-- Put email of the recipient here"
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "Yr 7 701 EOT test attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& "KDS ICT Dept" & vbLf & vbLf
.Attachments.Add PdfFile
Application.Visible = True
.Display
End With
If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
With CentralReg
For Each cell In Range("A2:A250")
If cell = Range("Results!B2").Value Then
cell.Offset(0, 4).Activate
ActiveCell.Value = Range("Results!B27").Value
End If
Next
End With
End Sub
I believe you are trying to refer to CentralReg which is a worksheet, which means you should qualify it as such.
Also, you should not dim variables that are similar to defined objects/properties in VBE. Try MyCell instead of cell (good practice, not required).
I am assuming you want to see if the value on sheet CentralReg in Column A is equal to sheet Result B2. If this condition is met, your MyCell will take on the value equal sheet Result B27
Dim MyCell As Range
Dim Result, NewValue as Variant
Result = ThisWorkbook.Sheets("Result").Range("B2")
NewValue = ThisWorkbook.Sheets("Result").Range("B27")
With ThisWorkbook.Sheets("CentralReg")
For Each MyCell In .Range("A2:A250")
If MyCell = Result Then MyCell.Offset(, 4) = NewValue
Next MyCell
End With
That with statement is useless as nothing actually uses it within the construct.
Delete with CentralReg and End with and it will work.
alternatively if CentralReg IS something like a sheet then you need to precede your code with a . so this: Range("A2:A250") becomes this: .Range("A2:A250") and so on, the . tells the code that it is related to whatever your with construct surrounds
I found a lot of examples but it's not working in my case and I don't know why.
Very basic code:
Sub Test()
Dim namCur As Name
For Each namCur In ActiveSheet.Names
MsgBox "Name: " & namCur.Name & ", Refers To: " & namCur.RefersTo
Next namCur
End Sub
And I have the same issue when I use Worksheets("Assumptions").Names
When I watch ActiveSheet.Name, this is correct I get "Assumptions", you can see on the picture below the list of named ranges. But I never get the MsgBox and the For loop goes directly to the end.
Edit: Very important, I need to loop only this sheet's named ranges, not the whole workbook
Any idea?
I use Excel 2016
Your solution will only list Names that have a scope set to only the ActiveSheet.
Change this
For Each namCur In ActiveSheet.Names
To this
For Each namCur In ThisWorkBook.Names
to list all names in the Workbook. You can then check the RefersTo address to check if it applies to the ActiveSheet.
Sub Test()
Dim namCur As Name
Dim TargetSheetName As String
TargetSheetName = "Assumptions"
For Each namCur In ThisWorkbook.Names
If Range(namCur.RefersTo).Parent.Name = TargetSheetName Then MsgBox "Name: " & namCur.Name & ", Refers To: " & namCur.RefersTo
Next namCur
End Sub
I am trying to add a Name to my workbook. The reference has an INDEX formula. I am getting an error on this line of code:
ActiveWorkbook.Names.Add Name:=RangeName, RefersTo:=Reference
I tried it with ActiveWorkbook and also tried defining a worksheet.
I guess it doesn't work, because the name range can not be matched with a worksheet because it has a function in it, but i do not know how to solve. Does anyone have a suggestion?
Sub NameRange_Add3()
Dim RangeName As String
Dim Reference As String
Dim i As Integer
For i = 2 To 6
RangeName = "list" & i
Reference = "=INDEX(tabla_1;;MATCH(" & "hszis" & i & ";hszi_list;0))"
ActiveWorkbook.Names.Add Name:=RangeName, RefersTo:=Reference
Next i
End Sub
When you are using creating formulas in VBA you need to use the English notation, which means points as decimal separators and commas as function argument separators.
You can either do what #brettdj did and use commas
Reference = "=INDEX(tabla_1,,MATCH(" & "hszis" & 1 & ",hszi_list,0))"
or use RefersToLocal instead of RefersTo
ActiveWorkbook.Names.Add Name:=RangeName, RefersToLocal:=Reference
I would prefer the first solution though because otherwise it could fail if you execute the macro on a machine with different language settings.
I ran it with
Reference = "=INDEX(tabla_1,MATCH(" & "hszis" & i & ",hszi_list,0))"
and it worked. Suggest you try removing the bonus ;
Reference = "=INDEX(tabla_1;MATCH(" & "hszis" & i & ";hszi_list;0))"
so I burned a whole day yesterday getting side tracked on a different process for toggling images on and off based on a cell value. The funny thing is it all started from me writing a wee bit of VBA to update the Header and Footer Information automatically prior to printing or saving.
Situation
I have 12 worksheets currently in the workbook.
Sheet1(HEADER AND FOOTER) contains all the information to go into the various header/footer locations.
Sheets 2-7 are the pages that get printed as a group and have the header and footers on them.
Sheets 2-6 are portrait letter pages with multiple pages on each sheet (I cannot force 1 page wide on certain sheets due to their layout).
Sheet 7 is landscape letter page.
If I print /save as pdf prior to writing the code and changing each page separately everything worked nice, all paged printed in their respective page layouts/setups.
When I implemented the VBA code in the beforeprint or beforesave in ThisWorkbook things did not go well. Depending on which variation of the VBA code I tried, either sheet 7 would adopt the portrait orientation and scaling same as the other sheets OR all sheets would be landscape and have the scaling of sheet 7.
OBJECTIVE
Update sheets 2 through 7 with the appropriate header/footer information while maintaining their original assigned page settings. That way when I print, sheets 2-6 are all portrait and sheet 7 is landscape all on letter paper.
What I have tried
I recorded a macro to get the base structure. Originally it had all sheets in one area and modifying them. I figured that the pages were all being made the same because they were all selected at the same time, So instead of selecting all them at once, I thought I would try modifying one sheet at a time. This lead to only one worksheet being printed, so I had to add reselecting all the sheets as the last line of code. This is the VBA code I currently have:
Private Sub WorkbookBeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "HEADER AND FOOTER" And InStr(1, Left(ws.Name, 5), "Table", vbTextCompare) = 0 Then
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.CenterHeader = Sheets(1).Range("B1").Value & Chr(10) & "Load Evaluation"
.RightHeader = _
"Calculated by: " & Sheets(1).Range("B3").Value & " Date: " & Sheets(1).Range("B4").Value & Chr(10) & "Checked By: " & Sheets(1).Range("B5").Value & " Date: " & Sheets(1).Range("B6").Value
.LeftFooter = "Project Number: " & Sheets(1).Range("B2").Value
.CenterFooter = "Page &P/&N"
.RightFooter = "Print Date: " & Sheets(1).Range("B7").Value
End With
End If
Next ws
Sheets(Array("General", "Loads", "Capacity", "Analysis", "POSTING", "SUMMARY")).Select
Sheets("General").Activate
End Sub
I was thinking maybe there is something wrong with the way I implemented the For Each as that is not a form I am familiar with. I was originally thinking about using a For x = 2 to ws.count - UDF_worksheet_count_names_starting_with_tables to loop through the sheets. I thought I would check in here first to see if there is a better approach to this problem.
So first off thanks to D.K. for the suggestion to change from activesheet.page setup to ws.pagesetup. This however did not solve the problem but did make a lot more sense. I then stumbled onto this thread: Excel headers/footers won't change via VBA unless blank. I was wondering what the line
Application.PrintCommunication = False
actually did. When I commented that line out the last sheet's layout no longer got updated/changed to match the other pages and things are working as intended.
This is what the final code looks like:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "HEADER AND FOOTER" And InStr(1, Left(ws.Name, 5), "Table", vbTextCompare) = 0 Then
With ws.PageSetup
.CenterHeader = Sheets(1).Range("B1").Value & Chr(10) & "Load Evaluation"
.RightHeader = _
"Calculated by: " & Sheets(1).Range("B3").Value & " Date: " & Sheets(1).Range("B4").Value & Chr(10) & "Checked By: " & Sheets(1).Range("B5").Value & " Date: " & Sheets(1).Range("B6").Value
.LeftFooter = "Project Number: " & Sheets(1).Range("B2").Value
.CenterFooter = "Page &P/&N"
.RightFooter = "Print Date: " & Sheets(1).Range("B7").Value
End With
End If
Next ws
End Sub
I am creating a table in my spreadsheet that contains categories, questions and answers for a quiz.
The user is presented with a form, allowing them to navigate around the workbook easily, this also includes a textbox option, allowing them to search for a phrase if they are unsure what category the question/answer may fall into.
I have generated a vlook up to pull from the table of categories/questions and answers to the user on a different worksheet.
I have also generated a count, so I am able to identify how many times this work appears across the quiz table.
My problem is I am struggling to develop a loop so that if the key phrase is found 6 times for example, i want 6 questions and answers to be listed to the user. Currently it is only pulling the final time it is found.
My current code includes the following:
Private Sub CommandButton1_Click()
If Len(search_text) = 0 Then
MsgBox "Please enter a key word to search for!", vbCritical
End If
Dim wordCount As Integer
wordCount = Application.WorksheetFunction.CountIf(Sheet1.Range("A2:c600"), "*" & search_text.Value & "*")
'Else: wordCount = WorksheetFunction.CountIf(Sheet1.Range("A2:c600"), search_text.Value)
If wordCount = 0 Then
MsgBox "No match found"
Else
Sheet2.Range("a7").Value = WorksheetFunction.VLookup("*" & search_text.Value & "*", Sheet1.Range("A2:c600"), 3, False)
Sheet2.Range("b7") = wordCount
End If
End Sub
Any advice on implementing a loop and to allow the question/answer to be printed one after another would be very much appreciated.
I have read many other question pages about this and none seem to match what I am trying to do.
Many thanks in advance
I use a combination of Find and FindNext to search through a range of cells for the term entered in the search_text input field. I added comments to my code to better help you understand what exactly is going on.
I don't know exactly what you need to do with the results when you find them, for now I just display a message box showing the match. We can work on what to actually do with the results if you want to clarify in the comments what exactly you want.
This code assumes you have a worksheet named Results
Private Sub CommandButton1_Click()
Dim rngResult As Range
Dim strFirstAddress As String
Dim i As Long
If Len(search_text.Text) = 0 Then
MsgBox "Please enter a key word to search for!", _
vbCritical
'Stop code exeuction if no search
'term is entered
Exit Sub
End If
'Clear the previous results range
Sheets("Results").Range("A2:C600").ClearContents
'Set i to row 2 of the results worksheet
i = 2
'Look in range A2:C600 of Sheet1
With Sheet1.Range("A2:C600")
'Perform the initial find
Set rngResult = .Find(What:=search_text.Text, LookAt:=xlPart)
'Check to ensure that the term is found
If Not rngResult Is Nothing Then
'Grab the cell address of the first match
'This will help to avoid an infinite loop
strFirstAddress = rngResult.Address
'Continue Searching
Do
'Display the output to you
'MsgBox "Matched '" & search_text.Text & "' to " & rngResult.Value & " in cell " & rngResult.Address
'Put the result on the results page
Sheets("Results").Range("A" & i & ":C" & i).Value = Range("A" & rngResult.Row & ":C" & rngResult.Row).Value
i = i + 1
'Move on to the next result
Set rngResult = .FindNext(rngResult)
'Break out of the loop when we return to the starting point of the search
Loop While Not rngResult Is Nothing And rngResult.Address <> strFirstAddress
End If
End With
'Clean up variables
Set rngResult = Nothing
End Sub