I have an excel sheet [Microsoft Office 2010] where the user can select a certain commodity & category, after which a list of suppliers linked to that commodity & category are printed on the sheet. I now want to print out hyperlinks next to this list of suppliers that perform a google search using the supplier as search term. This is the code I got right now: It checks whether the cells in column 6 are empty or not, if not that means a supplier name is printed in the cell. I then want a hyperlink to be printed in the column next to it that links to a google search using the suppliername as search term.
EDIT: code below works. Issue was in the if statement - isEmpty did not work for string value, but vbNullString fixed the issue.
Previous issueL
The printed links lead to the general google home page, with no search terms. I believe the reason why the links are leading to general google pages is because the actual cell values (which are used as search term) are not read properly. The code line "If Not IsEmpty(cellSupplierListed) Then" always runs, even when the cells have no suppliername in there.. I'm not sure why.
Also: Let's say there are 5 suppliers listed and the code reads over 300 rows (hard coded in code above), then still 300 links are printed out, while only 5 should have been printed out. (as only 5 of the 300 rows have values). Those 5 suppliers are printed out by previous code in the same sub and do indeed show up on the excel sheet. It just appears that the code below is not reading blank cells as being blank cells or non-blank cells as non-blank cells.
Dim cellSupplierListed As String
Dim csl As Integer
Dim h As Integer
h = 0
For csl = 1 To 300 'needs to be updated if more than 300 suppliers are listed
cellSupplierListed = Cells(9 + csl, 4).Value
If cellSupplierListed = vbNullString Then
Exit For
Else
h = h + 1
Range("G" & (9 + h)).Hyperlinks.Add Range("G" & (9 + h)), "http://www.google.com/search?q=" & cellSupplierListed, , , "Link"
End If
Next csl
From https://msdn.microsoft.com/en-us/library/office/ff822490.aspx
For Office 2013 and later, you can use the Hyperlinks.Add method
.Add(Anchor, Address, SubAddress, ScreenTip, TextToDisplay)
Example (from the above linked documentation):
With Worksheets(1)
.Hyperlinks.Add Anchor:=.Range("a5"), _
Address:="http://example.microsoft.com", _
ScreenTip:="Microsoft Web Site", _
TextToDisplay:="Microsoft"
End With
The following was tested in Office 2007:
Range("a5").Hyperlinks.Add Range("a5"), "http://www.google.com"
For the OP's actual question:
Change the following line
Cells(7, 9 + h) = Hyperlink("http://www.google.com/search?q=" & cellSupplierListed, "Link")
to
Range("F"&(9+h)).Hyperlinks.Add Range("F"&(9+h)), "http://www.google.com/search?q=" & cellSupplierListed,,,"Link"
You can copy the values and paste them back as html:
[f:f].Copy
Set o = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' New MSForms.DataObject
o.GetFromClipboard: s = o.GetText
Application.CutCopyMode = False
before = "<a href='http://www.google.com/search?q=": after = "'>Link</a><br>"
s = Replace(s, vbNewLine, after & vbNewLine & before)
s = "<html>" & before & s & after
s = Replace(s, before & after, "<br>") ' replace the blank values
o.SetText s: o.PutInClipboard
[g1].PasteSpecial "Text"
Related
ISSUE: How to fix a Word VBA FOR EACH subroutine that seeks to insert a comment at each tracked change and, yet, will freeze VBA/Word at certain pages of a document and not other pages.
The below code works on some documents throughout the entire document. Other documents, unfortunately, will freeze at certain locations in the document.
I've F8 stepped through, for example, to find one document would freeze at pages 6 and 7 of a 22 page document. Strangely, however, I could run the code to insert comments at each tracked pages on all other pages.
Dim rev As Revision, txt As String
Dim pgno1 As String
Dim pgno2 As String
Application.ScreenUpdating = False
ActiveDocument.TrackRevisions = False
'check Revisions
For Each rev In ActiveDocument.Revisions
Select Case rev.Type
Case wdRevisionDelete
txt = Left(rev.Range.Text, 3) 'the deleted text
rev.Range.Comments.Add Range:=rev.Range, Text:="Pg [#" & pgno1 & "] BLAH " & txt & " [ ... ]“
Case wdRevisionInsert
txt = Left(rev.Range.Text, 3) 'the inserted text
rev.Range.Comments.Add Range:=rev.Range, Text:= "Pg [#" & pgno1 & "] BLAH " & txt & " […]”
End Select
Next rev
ActiveDocument.TrackRevisions = True
GOAL: Insert comment with specific text at each tracked change, throughout entire docxz
ERRORS: No messages. VBA and Word freeze, requiring restart.
The Range.SpecialCells method can be used to return a Range object meeting certain criteria. The type of criteria is specified using an xlCellType constant.
One of those constants (xlCellTypeBlanks) is described as referring to "Empty cells" with no further elaboration.
Does anyone know what definition of "Empty" this method uses? Does it include cells with no values/formulas but various other features (data validation, normal formatting, conditional formatting, etc)?
That type includes the subset of cells in a range that contain neither constants nor formulas. Say starting with an empty sheet we put something in A1 and A10 and then run:
Sub ExtraSpecial()
Set r = Range("A:A").SpecialCells(xlCellTypeBlanks)
MsgBox r.Count
End Sub
we get:
Formatting and Comments are not included. Also note that all the "empty" cells below A10 are also ignored.
Papalew's response noted that "xlCellTypeBlanks" excludes any cells not within a specific version of the "used range" that's calculated in the same way as the special cell type "xlCellTypeLastCell". Through testing I've discovered that "xlCellTypeLastCell" returns the last cell of the "UsedRange" property as of the last time the property was calculated.
In other words, adding a line that references "UsedRange" will actually change the behavior of the SpecialCells methods. This is such unusual/unexpected behavior that I figured I'd add an answer documenting it.
Sub lastCellExample()
Dim ws As Worksheet
Set ws = Sheets.Add
ws.Range("A1").Value = "x"
ws.Range("A5").Value = "x"
ws.Range("A10").Value = "x"
'Initially the "UsedRange" and calculated used range are identical
Debug.Print ws.UsedRange.Address
'$A$1:$A$10
Debug.Print ws.Range(ws.Range("A1"), _
ws.Cells.SpecialCells(xlCellTypeLastCell)).Address
'$A$1:$A$10
Debug.Print ws.Cells.SpecialCells(xlCellTypeBlanks).Address
'$A$2:$A$4,$A$6:$A$9
'After deleting a value, "UsedRange" is recalculated, but the last cell is not...
ws.Range("A10").Clear
Debug.Print ws.Range(ws.Range("A1"), _
ws.Cells.SpecialCells(xlCellTypeLastCell)).Address
'$A$1:$A$10
Debug.Print ws.Cells.SpecialCells(xlCellTypeBlanks).Address
'$A$2:$A$4,$A$6:$A$10
Debug.Print ws.UsedRange.Address
'$A$1:$A$5
'...until you try again after referencing "UsedRange"
Debug.Print ws.Range(ws.Range("A1"), _
ws.Cells.SpecialCells(xlCellTypeLastCell)).Address
'$A$1:$A$5
Debug.Print ws.Cells.SpecialCells(xlCellTypeBlanks).Address
'$A$2:$A$4
End Sub
The definition does indeed contain the idea of having nothing in the cell, i.e. it excludes any cell that contains either:
a numerical value
a date or time value
a text string (even an empty one)
a formula (even if returning an empty string)
an error
a boolean value
But it also excludes any cell that’s not within the range going from A1 to the last used cell of the sheet (which can be identified programmatically through ws.cells.specialCells(xlCellTypeLastCell), or by using the keyboard Ctrl+End).
So if the sheet contains data down to cell C10 (i.e. Ctrl+End brings the focus to cell C10), then running Range("D:D").specialCells(xlCellTypeBlanks) will fail.
NB The range A1 to LastCellUsed can sometimes be different from the used range. That would happen if some rows at the top and/or some columns at on the left never contained any data.
On the other hand, cells that fit the empty definition above will be properly identified no matter any of the followings:
size or colour of font
background colour or pattern
conditional formatting
borders
comments
or any previous existence of these that would later have been cleared.
A bit beside the main subject, let me ask a tricky question related to how the term BLANK might be defined within Excel:
How can a cell return the same value for CountA and CountBlank?
Well, if a cell contains ' (which will be displayed as a blank cell), both CountA and CountBlank will return the value 1 when applied to that cell. My guess is that technically, it does contain something, though it is displayed as a blank cell. This strange feature has been discussed here.
Sub ZeroLengthString()
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Range("A2").Value = ""
ws.Range("A3").Value = Replace("a", "a", "")
ws.Range("A4").Value = """"
ws.Range("A6").Value = "'"
ws.Range("A7").Formula= "=if(1=2/2,"","")"
ws.Range("B1").Value = "CountA"
ws.Range("C1").Value = "CountBlank"
ws.Range("B2:B7").FormulaR1C1 = "=CountA(RC[-1])"
ws.Range("C2:C7").FormulaR1C1 = "=CountBlank(RC[-2])"
For i = 2 To 7
Debug.Print "CountA(A" & i & ") = " & Application.WorksheetFunction.CountA(ws.Range("A" & i))
Debug.Print "CountBlank(A" & i & ") = " & Application.WorksheetFunction.CountBlank(ws.Range("A" & i))
Next i
End Sub
In this example, both lines 6 & 7 will return 1 for both CountA and CountBlank.
So the term Blank doesn’t appear to be defined a unique way within Excel: it varies from tool to tool.
I'm new to this site, but I have already found some nice advice on how to solve problems in VBA. Now I'm here to ask help on a sub that gives me problems with Hyperlinks.
In particular, my problem is similar to the one described in this topic:
Excel VBA Get hyperlink address of specific cell
I have a worksheet full of hyperlink, but I need to extract only the addresses present in the "H" column, starting from "H6" and writing them into the "N" column, starting from "N6".
I put down this code:
Sub EstraiIndirizzoPut()
Dim IndirizzoInternet As Hyperlink
Dim ISINs As String
i = 6
For Each IndirizzoInternet In Sheets("XXX").Range("H" & i).Hyperlinks
IndirizzoInternet.Range.Offset(0, 6).Value = IndirizzoInternet.Address
ISINs = Mid(IndirizzoInternet.Address, 78, 12)
Range("N" & i).Value = ISINs
i = i + 1
Next
End Sub
It works fine only for the first "H6" cell, but at the "Next" point, when it should read the "H7" cell, it goes instead to "End Sub", terminating the routine, altough the "H7" cell, as well many others down the column, are filled with hyperlinks (it gives me "Nothing" value).
Could you please suggest me where I get this wrong? Many thanks.
Your loop isnt set up correctly. Try it like this instead:
For i = 6 to 100
Set IndirizzoInternet = Sheets("XXX").Range("H" & i).Hyperlinks
IndirizzoInternet.Range.Offset(0, 6).Value = IndirizzoInternet.Address
ISINs = Mid(IndirizzoInternet.Address, 78, 12)
Range("N" & i).Value = ISINs
Next
How do you know when to stop the loop? Is it a preset number of rows? If it not, you will want to have something determine the last row to process and replace the 100 with that variable.
I currently work for a company which uses a set house-style for its documents. This includes multi-levelled numbered headings built in to our Word template. I.e.
Heading 1
1.1 Heading 2
1.1.1 Heading 3
etc...
A large part of our current task involves adding in cross references to other parts in the document. This can be quite time consuming when the doc runs to several hundred pages with around 10 references on each page.
What I was wondering was if a macro could be set up to add a x-ref based on whatever is highlighted by the cursor. I.e. if you had a sentence that read "please refer to clause 3.2" you could highlight the "3.2" part, run the macro and have the x-ref linked to heading 3.2 be inserted.
Not sure if this is even possible but would be grateful for any advice.
This code will - conditionally - do what you want.
Sub InsertCrossRef()
Dim RefList As Variant
Dim LookUp As String
Dim Ref As String
Dim s As Integer, t As Integer
Dim i As Integer
On Error GoTo ErrExit
With Selection.Range
' discard leading blank spaces
Do While (Asc(.Text) = 32) And (.End > .Start)
.MoveStart wdCharacter
Loop
' discard trailing blank spaces, full stops and CRs
Do While ((Asc(Right(.Text, 1)) = 46) Or _
(Asc(Right(.Text, 1)) = 32) Or _
(Asc(Right(.Text, 1)) = 11) Or _
(Asc(Right(.Text, 1)) = 13)) And _
(.End > .Start)
.MoveEnd wdCharacter, -1
Loop
ErrExit:
If Len(.Text) = 0 Then
MsgBox "Please select a reference.", _
vbExclamation, "Invalid selection"
Exit Sub
End If
LookUp = .Text
End With
On Error GoTo 0
With ActiveDocument
' Use WdRefTypeHeading to retrieve Headings
RefList = .GetCrossReferenceItems(wdRefTypeNumberedItem)
For i = UBound(RefList) To 1 Step -1
Ref = Trim(RefList(i))
If InStr(1, Ref, LookUp, vbTextCompare) = 1 Then
s = InStr(2, Ref, " ")
t = InStr(2, Ref, Chr(9))
If (s = 0) Or (t = 0) Then
s = IIf(s > 0, s, t)
Else
s = IIf(s < t, s, t)
End If
If LookUp = Left(Ref, s - 1) Then Exit For
End If
Next i
If i Then
Selection.InsertCrossReference ReferenceType:="Numbered item", _
ReferenceKind:=wdNumberFullContext, _
ReferenceItem:=CStr(i), _
InsertAsHyperlink:=True, _
IncludePosition:=False, _
SeparateNumbers:=False, _
SeparatorString:=" "
Else
MsgBox "A cross reference to """ & LookUp & """ couldn't be set" & vbCr & _
"because a paragraph with that number couldn't" & vbCr & _
"be found in the document.", _
vbInformation, "Invalid cross reference"
End If
End With
End Sub
Here are the conditions:-
There are "Numbered Items" and "Headings" in a document. You asked for Headings. I did Numbered Items because I don't have that style on my PC. However, on my PC "Headings" are numbered items. If the code doesn't work on your documents, exchange wdRefTypeNumberedItem for wdRefTypeHeading at the marked line in the code.
I presumed a numbering format like "1" "1.1", "1.1.1". If you have anything different, perhaps "1." "1.1.", "1.1.1.", the code will need to be tweaked. The key points are that the code will look for either a space or a tab following the number. If it is followed by a period or closing bracket or a dash it won't work. Also, if you happen to select "1.2." (with the final full stop) in the text the code will ignore the full stop and look for a reference "1.2". Note that the code is insensitive to casual mistakes in the selection. It will remove any leading or trailing spaces as well as accidentally included carriage returns or paragraph marks - and full stops.
The code will replace the selection you make with its own (identical) text. This may cause existing formatting to change. In fact the inserted Reference Field takes the text from the target. I didn't quite figure out which format it applies, the target's or the one being replaced. I didn't deal with this problem, if it is one.
Please take a look at the properties of the cross reference the code inserts. You will see that InsertAsHyperlink is True. You can set it to False, if you prefer. IncludePosition is False. If you set this property to True you would see "above" or "below" added to the number the code replaces.
Yes it is totally possible...
I'll give you (an example of) the key elements:
' Check if a reference exists
If instr(lcase(selection.Sentences(1).Text), "refer to clause") then
' Figure out the reference number...
(see here: https://stackoverflow.com/questions/15369485/how-to-extract-groups-of-numbers-from-a-string-in-vba)
' Get a list of available references
refList = ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem)
' Add the reference
selection.InsertCrossReference(wdRefTypeNumberedItem ,wdNumberFullContext, xxxxxx...
I am getting killed by excel, I'm not 100% sure it can do exactly what I'm needing. I've tried various functions and can come close, but none are perfect. I've uploaded a spreadsheet as an example. I have a sheet of mailboxes, followed by a cell with the users who have access to the mailbox. The cell has anywhere from 0 to 5 users separated by commas. The second sheet has a list of users. What I need is a way to parse out the first sheet, either highlight on the first sheet, or copy to another sheet; all the mailboxes that all the associated users match in the second cell appear on the second sheet.
The real world sheet I have has over 2500 mailboxes with as many as 205 (as few as 0) associated users, so I desperately need a way to mechanically filter the sheet. I'm trying to filter the mailboxes that all the associated users are present on a second sheet.
I've tried using vlookup, index/match and a few others, and what seems to trip it up is having the comma separation. Using ""& cell_i'm_looking_for &"" returns nothing so I'm guessing I need to try something else. I also have the sheet with all the users in separate cells.
I downloaded your sheet and created a module with the following function inside of it:
Function mymailboxes(who As Range, lookup As Range)
Dim myRow As Range
For Each myRow In lookup
If InStr(myRow.Cells(1, 2).Value, who.Value) > 0 Then
myReturn = myReturn & "," & myRow.Cells(1, 1).Value
End If
Next
'cut off the first ,
myReturn = Right(myReturn, Len(myReturn) - 1)
mymailboxes = myReturn
End Function
Then on Sheet 2, Cell E2 I gave the following formula: =mymailboxes(A2, Sheet1!A1:B50) which gave me the following results: mailbox1,mailbox2,mailbox4,mailbox8,mailbox12,mailbox17,mailbox21,mailbox25,mailbox28,mailbox34,mailbox39,mailbox41,mailbox42,mailbox44,mailbox49,mailbox50
I hope this helps.
To get a list of invalid users the following function will help.
Function get_invalid_users(users As Range, validusers As Range)
Dim myRow As Range
myusers = Split(users, ",")
myReturn = ""
For Each user In myusers
is_valid_user = False
'Guilty until proven innocent
For Each myRow In validusers
If myRow.Cells(1, 1).Value = user Then
is_valid_user = True
'Proven innocent, break out of the loop, no double jeopardy.
Exit For
End If
Next
If is_valid_user = False Then
myReturn = myReturn & "," & user
End If
Next
If Len(myReturn) > 0 Then
myReturn = Right(myReturn, Len(myReturn) - 1)
Else
myReturn = ""
End If
get_invalid_users = myReturn
End Function
Sheet 1, Cell C2 with formula: =get_invalid_users(B2, Sheet2!$A$1:$A$3) returned zx1234