I have a list of more than 150 cells which contained hyperlinks to images on local hard,
yesterday I found a way to popup those images by inserting comments with filling the background with a picture.
It will be tough to do this one by one, So I want a VBA script to insert comments on selected cells and fill the comments background with images which its hyperlink located in every cell.
Is That possible or should I do it manually?
Here is an Example of cells contents
I1 D:\My Pictures\example 001.jpg
I2 D:\My Pictures\example 021.jpg
I3 D:\My Pictures\example 030.jpg
Recording a macro shows that the above is possible. A little tweaking is in order, though. As an example, the following macro creates an image pop-up via comment for A1.
Sub Test()
Dim Comm As Comment
On Error Resume Next
Range("A1").AddComment
Range("A1").Comment.Visible = False
Set Comm = Range("A1").Comment
Comm.Shape.Fill.UserTextured "C:\foo\bar.gif"
End Sub
The On Error Resume Next is for handling ranges that already have comments, so you can keep on running the macro repeatedly. I set .Visible to False to be safe that the images don't become permanent pop-ups (should only appear on hover).
We can tweak the above further to create a subroutine that takes in a range and a string as arguments so we can call it repeatedly across ranges.
Sub CreatePopUp(TargetRange As Range, PathToImage As String)
Dim Comm As Comment
On Error Resume Next
With TargetRange
.AddComment
.Comment.Visible = False
Set Comm = .Comment
End With
Comm.Shape.Fill.UserTextured PathToImage
End Sub
The above can be called like so:
Sub MassPopUp()
Dim rCell As Range
For Each rCell In [A1:A10]
CreatePopUp rCell, "Blah"
Next
End Sub
Let us know if this helps.
EDIT:
If your date is in, for example, I1:I10, and they contain the exact paths to the image files, then the above can be written like so:
Sub MassPopUp()
Dim rCell As Range
For Each rCell In [I1:I10]
CreatePopUp rCell, rCell.Value
Next
End Sub
rCell.Value will take the value inside the cell, pass it to the subroutine that inserts an image, and apply it as a comment to rCell with the proper image extracted. This should not fail. Just make sure the value in the cell are proper paths to their respective files.
Related
I am currently working on a userform which has a "Clear Process" command button. The idea is that my userform has a listbox which will list all of the current processes.
From here the user will select which process(es) he/she would like to clear from the worksheet (delete all rows relating to the process).
Embedded in the code I have used the word "Lisa" as a point of reference for the previous userform to know which cell the Process Name should be, using the offset function.
I would like to be able to use the word "Lisa" once the process to be deleted has been identified by the user. This would always be the row where "Lisa" is found and 19 rows below.
I have started some code but when trying to find "Lisa" depending on the selection made by the user I came across an issue.
Private Sub ClearButton_Click()
Dim findvalue As Range
Dim cDelete As VbMsgBoxResult
'hold in memory
Application.ScreenUpdating = False
'check for values
If Emp1.Value = "" Or Emp2.Value = "" Then
MsgBox "There are no processes to delete"
Exit Sub
End If
'confirm process should be deleted
cDelete = MsgBox("Are you sure you want to delete this process?", vbYesNo)
If cDelete = vbYes Then
'find the process to be deleted
'''''''set findvalue =
'''''''delete entire process
findvalue.EntireRow.Delete
End If
End Sub
Hopefully this is enough information, any help would be greatly appreciated :)
If you use Named ranges for your processes, which seems to be almost mandatory in your case, then you can do the following:
Sub DeleteNamedRange(rngName As String)
Range(rngName).ClearContents
ThisWorkbook.Names(rngName).Delete
End Sub
Invoke the Sub this way:
Call DeleteNamedRange("Lisa")
Something as small as this one would set a range to a found value and delete it:
Public Sub TestMe()
Dim findValue As Range
Set findValue = Selection.Find("Lisa")
findValue.EntireRow.Delete
End Sub
As a good practice, you may check whether the findValue is not nothing before deleting. Thus, you avoid an error:
If Not findValue Is Nothing Then
findValue.EntireRow.Delete
End If
And if you want to make the code even one step further, keep in mind that the default value of the argument After in Find() is the first cell. Thus, Find() always start looking from the second cell. To avoid this, and to start looking from the first cell, it is considered a good practice to pass the After:= argument explicitly:
Public Sub TestMe()
Dim findValue As Range
Dim selectedValue As Range
Set selectedValue = ActiveSheet.Range(Selection.Address)
With selectedValue
Set findValue = .Find("Lisa", after:=.Cells(.Cells.Count))
End With
If Not findValue Is Nothing Then
findValue.EntireRow.Delete
End If
End Sub
To make the code even more "interesting", one may decide to check whether a range is selected (a shape can be also selected). Thus, the TypeName(Selection) can be used with something like this:
If TypeName(Selection) <> "Range" Then
MsgBox "Range is not selected!"
Exit Sub
End If
Range.Find MSDN
I know that this probably isn't the most ideal way to to do this but just bear with me.
I have a document with a few tables on it. I'm using a userform to search the tables/sub-categories and return the relevant values. I want to select the sub categories with a range of option buttons on a userform, these will in turn set the range for the search function to look within. I also want to dynamically update the option buttons if a new table was to be added or anything along those lines.
The only thing that differentiates the title of a sub-category/table, and the items within it, is that the title of a sub-category/table is bold. So what I'm looking to do is search the first column of the spreadsheet and return the names of any entries in bold. These values are then used to set the names of the option buttons :).
The following function is my attempt at finding the text entities in column a that are in bold, returning them and setting each to an individual variable to be used in another function. The bold1 .... variables are all globally defined variables as I need them in another sub, as is the page variable which contains the relevant page to be used. Currently the code returns an error stating "variable or with block not set" and using the debugger I can see that bold1 .... and all the other boldx variables have no value set. Does anybody know whats going on/how to fix this function.
Thanks in advance :)
Sub SelectBold()
Dim Bcell As Range
For Each Bcell In Worksheets(Page).Range("A1:A500")
If Bcell.Font.Bold = True Then
Set bold1 = Bcell
End If
Next
End Sub
EDIT: I simplified the above function, to remove clutter and help narrow in on the issue. I want the above function to store the contents of the found cell (any cell in the document in bold at this stage) in the variable bold1
This will return an array of values from bold cells in column A of Page.
You can fill a combo or list box with theses values using their list property.
ComboBox1.List = getSubCategories("Sheet1")
Function getSubCategories(Page As String) As String()
Dim arrSubCategories() As String
Dim count As Long
Dim c As Range
With Worksheets(Page)
For Each c In .Range("A2", .Range("A" & Rows.count).End(xlUp))
If c.Font.Bold Then
ReDim Preserve arrSubCategories(count)
arrSubCategories(count) = c.Value
count = count + 1
End If
Next
End With
getSubCategories = arrSubCategories
End Function
you may find useful to have a Range returned with subcategories cells found:
Function SelectBold(Page As String, colIndex As String) As Range
With Worksheets(Page)
With .Range(colIndex & "1", .Cells(.Rows.Count, colIndex).End(xlUp)).Offset(, .UsedRange.Columns.Count)
.FormulaR1C1 = "=if(isbold(RC[-1]),"""",1)"
.Value = .Value
If WorksheetFunction.CountA(.Cells) < .Rows.Count Then Set SelectBold = Intersect(.SpecialCells(xlCellTypeBlanks).EntireRow, .Parent.Columns(1))
.Clear
End With
End With
End Function
Function IsBold(rCell As Range)
IsBold = rCell.Font.Bold
End Function
to be possibly exploited as follows:
Option Explicit
Sub main()
Dim subCategoriesRng As Range, cell As Range
Set subCategoriesRng = SelectBold(Worksheets("bolds").Name, "A") '<--| pass worksheet name and column to search in
If Not subCategoriesRng Is Nothing Then
For Each cell In subCategoriesRng '<--| loop through subcategories cells
'... code
Next cell
End If
End Sub
I have a workbook with many sheets and images that have random names and arbitrary order, the only image that I need is always in the range A2:C14, I'm using the following code to copy the image:
firstSheet.Range("A2:C14").Copy
secondSheet.Range("I6").PasteSpecial
But it only copies the cell text, not the image.
Is there a way to copy an image using Range("A2:C14)" or another way to select the cell to copy the image?
Since CopyPicture is a method of a Shape object, unless you already have a pointer to it, using the Shapes collection is unavoidable
Something like this
Sub Demo()
Dim shp As Shape
Dim rng As Range
Set rng = firstSheet.Range("A2:C14")
For Each shp In firstSheet.Shapes
If Not Intersect(rng, shp.TopLeftCell) Is Nothing Then
' Found it
shp.CopyPicture
secondSheet.Range("I6").PasteSpecial
Exit Sub
End If
Next
End Sub
I have tried code that I've found here on stackoverflow, and elsewhere but they aren't working as I think they can. I'll list them below. I'm almost certain this is an easy question.
What I'm trying to do: If in any of the cells in the range A2:A100 there is any text or number whatsoever, then make the worksheet tab red. And I will need to do this on over 20 tabs. This must execute upon opening the workbook, and thus not require manually changing a cell or recalculating.
The problems I've had with other code: As far as I can tell they require editing a cell, and then quickly hitting enter again. I tried SHIFT + F9 to recalculate, but this had no effect, as I think this is only for formulas. Code 1 seems to work albeit with having to manually re-enter text, but no matter what color value, I always get a black tab color.
Code I've tried:
Code 1:
Private Sub Worksheet_Change(ByVal Target As Range)
MyVal = Range("A2:A27").Text
With ActiveSheet.Tab
Select Case MyVal
Case ""
.Color = xlColorIndexNone
Case Else
.ColorIndex = 6
End Select
End With
End Sub
Code 2: This is from a stackoverflow question, although I modified the code slightly to fit my needs. Specifically, if in the set range there are no values to leave the tab color alone, and otherwise to change it to color value 6. But I'm sure I've done something wrong, I'm unfamiliar with VBA coding.
Private Sub Worksheet_Calculate()
If Range("A2:A100").Text = "" Then
ActiveWorkbook.ActiveSheet.Tab.Color = xlColorIndexNone
Else
ActiveWorkbook.ActiveSheet.Tab.Color = 6
End If
End Sub
Thanks for your help!
I posted this on superuser first, but perhaps stackoverflow is more appropriate since it is explicitly programming-related.
Only two things will be able to switch the condition in this statement:
If Range("A2:A100").Text = "" Then
You've already identified both of them, changing the contents of the one of the cells in that range on a worksheet, or a formula in one of those cells recalculating to or from a value of "". As far as event triggers go, if the formula result changes, both the WorkSheet_Calculate and Worksheet_Change events will fire. Of the two, Worksheet_Change is the one to respond to, because WorkSheet_Calculate will only fire if any of the cells in A2:A100 contain a formula. Not if they only contain values - your "Code 2" isn't wrong, the event was just never firing.
The simple solution is to set your tab colors when you open the workbook. That way it doesn't matter if you have to activate a cell in that range and change it - that's only way the value you're testing against is going to change.
I'd do something like this (code in ThisWorkbook):
Option Explicit
Private Sub Workbook_Open()
Dim sheet As Worksheet
For Each sheet In Me.Worksheets
SetTabColor sheet
Next sheet
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Sh.Range("A2:A100")) Is Nothing Then
SetTabColor Sh
End If
End Sub
Private Sub SetTabColor(sheet As Worksheet)
If sheet.Range("A2:A100").Text = vbNullString Then
sheet.Tab.Color = xlColorIndexNone
Else
sheet.Tab.Color = 6
End If
End Sub
EDIT: To test for the presence of specific text, you can do the same thing but need to have the test check every cell in the range you're monitoring.
Private Sub SetTabColor(sheet As Worksheet)
Dim test As Range
For Each test In sheet.Range("A2:A100")
sheet.Tab.Color = xlColorIndexNone
If test.Text = "whatever" Then
sheet.Tab.Color = vbRed
Exit For
End If
Next test
End Sub
Maybe test the len of the trimmed joined string of cells:
Private Sub Worksheet_Calculate()
If Len(Trim(Join(Application.Transpose(Range("A2:A100"))))) = 0 Then
ActiveWorkbook.ActiveSheet.Tab.Color = xlColorIndexNone
Else
ActiveWorkbook.ActiveSheet.Tab.Color = 6
End If
End Sub
This code will fire off every time the sheet calculates though as it is event code, I am not sure if that is what you want? If not then post back and we can drop it into a normal sub for you and make it poll all the sheets to test.
Worksheet_Change function will get called everytime there's change in the target range. You just need to place the code under Worksheet. If you have placed the code in the module or Thisworkbook then it wont work.
Paste the below in Sheet1 of your workbook and check if it works. Of Course you will need to do modification to the below code as I have not written complete code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WatchRange As Range
Dim IntersectRange As Range
Set WatchRange = Range("A1:A20")
Set IntersectRange = Intersect(Target, WatchRange)
If IntersectRange Is Nothing Then
''Here undo tab color
Else
ActiveSheet.Tab.ColorIndex = 6
End If
End Sub
Worksheet_Change triggers when a cell value is changed (which is what I want), but it also triggers when you enter a cell as if to edit it but don't actually change the cell's value (and this is what I don't want to happen).
Say I want to add shading to cells whose value was changed. So I code this:
Private Sub Worksheet_Change(ByVal Target As Range)
Target.Interior.ColorIndex = 36
End Sub
Now to test my work: Change cell A1 and the cell gets highlighted. That's the desired behaviour. So far so good. Then, double click B1 but don't change the value there and then click C1. You'll notice B1 gets highlighted! And this is not the desired behaviour.
Do I have to go through the methods discussed here of capturing the old value, then compare old to new before highlighting the cell? I certainly hope there's something I'm missing.
I suggest automatically maintaining a "mirror copy" of your sheet, in another sheet, for comparison with the changed cell's value.
#brettdj and #JohnLBevan essentially propose doing the same thing, but they store cell values in comments or a dictionary, respectively (and +1 for those ideas indeed). My feeling, though, is that it is conceptually much simpler to back up cells in cells, rather than in other objects (especially comments, which you or the user may want to use for other purposes).
So, say I have Sheet1 whose cells the user may change. I created this other sheet called Sheet1_Mirror (which you could create at Workbook_Open and could set to be hidden if you so desire -- up to you). To start with, the contents of Sheet1_Mirror would be identical to that of Sheet1 (again, you could enforce this at Workbook_Open).
Every time Sheet1's Worksheet_Change is triggered, the code checks whether the "changed" cell's value in Sheet1 is actually different from that in Sheet1_Mirror. If so, it does the action you want and updates the mirror sheet. If not, then nothing.
This should put you on the right track:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
For Each r In Target.Cells
'Has the value actually changed?
If r.Value <> Sheet1_Mirror.Range(r.Address).Value Then
'Yes it has. Do whatever needs to be done.
MsgBox "Value of cell " & r.Address & " was changed. " & vbCrLf _
& "Was: " & vbTab & Sheet1_Mirror.Range(r.Address).Value & vbCrLf _
& "Is now: " & vbTab & r.Value
'Mirror this new value.
Sheet1_Mirror.Range(r.Address).Value = r.Value
Else
'It hasn't really changed. Do nothing.
End If
Next
End Sub
This code uses Comments to store the prior value (Please note if you do need the comments for other purposes this method will remove them)
Cells that have no value have colour reset to xlNone
An intial value typed into a cell is blue (ColorIndex 34)
If the value is changed the cell goes from blue to yellow
Normal module - turn display of comments off
Sub SetCom()
Application.DisplayCommentIndicator = xlNoIndicator
End Sub
Sheet code to capture changes
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim shCmt As Comment
For Each rng1 In Target.Cells
If Len(rng1.Value) = 0 Then
rng1.Interior.ColorIndex = xlNone
On Error Resume Next
rng1.Comment.Delete
On Error GoTo 0
Else
On Error Resume Next
Set shCmt = rng1.Comment
On Error GoTo 0
If shCmt Is Nothing Then
Set shCmt = rng1.AddComment
shCmt.Text Text:=CStr(rng1.Value)
rng1.Interior.ColorIndex = 34
Else
If shCmt.Text <> rng1.Value Then
rng1.Interior.ColorIndex = 36
shCmt.Text Text:=CStr(rng1.Value)
End If
End If
End If
Next
End Sub
Try this code. When you enter a range it stores the original cell values in a dictionary object. When the worksheet change is triggered it compares the stored values with the actuals and highlights any changes.
NB: to improve efficiency reference microsoft scripting runtime & replace the As Object with As Scripting.Dictionary and the CreateObject("Scripting.Dictionary") with New Scripting.Dictionary.
Option Explicit
Private previousRange As Object 'reference microsoft scripting runtime & use scripting.dictionary for better performance
'I've gone with late binding to avoid references from confusing the example
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Variant
For Each cell In Target
If previousRange.Exists(cell.Address) Then
If previousRange.Item(cell.Address) <> cell.FormulaR1C1 Then
cell.Interior.ColorIndex = 36
End If
End If
Next
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cell As Variant
Set previousRange = Nothing 'not really needed but I like to kill off old references
Set previousRange = CreateObject("Scripting.Dictionary")
For Each cell In Target.Cells
previousRange.Add cell.Address, cell.FormulaR1C1
Next
End Sub
ps. any vba code to update cells (even just colour) will stop excel's undo functionality from working! To get around this you can reprogram undo functionality, but it can get quite memory intensive. Sample solutions: http://www.jkp-ads.com/Articles/UndoWithVBA00.asp / http://www.j-walk.com/ss/excel/tips/tip23.htm
I know this is an old thread, but I had exactly the same problem like this "Change cell A1 and the cell gets highlighted. That's what I'd expect. Double click B1 but don't change the value there and then click C1. You'll notice B1 gets highlighted! "
I didn't wanted to highlight a cell if it was only doubleclicked without value inside.
I solved in in easy way. Maybe it help somebody in future.
I've just added this on the beggining of the event:
If Target.Value = "" Then
Exit Sub
End If
I found this other thread that provides ways to captures the old value, so you can compare it with the "new" value and if those are then simply let it do nothing.
How do I get the old value of a changed cell in Excel VBA?