I am unsuccessfully trying to adjust code that was created by a previous coworker. Currently we use this code below. It is attached to a button on an excel worksheet, this inserts an image into a specified range of cells, it resizes the image then lands on a cell below to type a description. The problem we are having is our template is now being moved from our server to outside locations. So all of the images are now just broken links. I have attempted several adjustments based on other posts, but none have been successful.
Private Sub Picture1_Click()
' Select Image From File
With Application.FileDialog(msoFileDialogFilePicker)
If .Show Then
PicLocation = .SelectedItems(1)
Else
PicLocation = ""
End If
End With
' Error Check
If PicLocation = "" Then
MsgBox "No picture selected"
Exit Sub
End If
'Initialization
Dim TargetCells As Range
ActiveSheet.Unprotect
Set TargetCells = Range("B9:H24")
' Error check 2
If PicLocation <> "False" Then
Set p = ActiveSheet.Pictures.Insert(PicLocation)
Else
Exit Sub
End If
' Set image dimensions
With p.ShapeRange
.LockAspectRatio = msoTrue
.Height = TargetCells.Height
If .Width > TargetCells.Width Then .Width = TargetCells.Width
End With
' Set image location
With p
.top = TargetCells.top
.Left = TargetCells.Left
.PrintObject = True
End With
' Close out operations
Range("a25").Select
Set p = Nothing
End Sub
I had the same issues when switching versions of Excel a few years ago. My macro now uses .Shapes.addPicture Modified a piece of your code below
If PicLocation <> "False" Then
Set p = ActiveSheet.Shapes.addPicture fileName:=PicLocation, linktofile:=False, savewithdocument:=True
Else
Exit Sub
End If
Related
This should be simple. I am working with userforms. I want to save a number that is stored in a cell and concatenate it with "lbl" and store it in a variable called Label. This works. I Then need to use the property .Caption but get a 424 error. Replacing the variable with what is stored in it ("lbl1"), the code runs.
Not sure why this is not working. Any help appreciated.
Sub ErrorExample()
Dim Label As String
'Clear previous click
If Worksheets("BackEnd").Range("D2").Value = "" Then
'No previous click
Else
'This does not work
Label = "lbl" & Worksheets("BackEnd").Range("D2").Value
With Label
'Clear previous click
.Caption = ""
End With
'This works
With lbl2
'Clear previous click
.Caption = ""
End With
End If
End Sub
Userform: Reference a Control By Its Name
Copy the code into the user form's module.
Private Sub ToClearOrNotToClear()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("BackEnd")
Dim Label As String: Label = CStr(ws.Range("D2").Value)
Dim lbl As Control
If Len(Label) > 0 Then
On Error Resume Next
Set lbl = Controls("lbl" & Label)
On Error GoTo 0
If lbl Is Nothing Then
MsgBox "Label not found!", vbCritical
Exit Sub
End If
If Len(CStr(lbl.Caption)) = 0 Then
MsgBox "Label is clear!", vbExclamation
Exit Sub
End If
lbl.Caption = ""
MsgBox "Label cleared.", vbInformation
End If
End Sub
I have an Excel spreadsheet consisting of several sheets. In each sheet I have a Button 1.
In order to move this button to Range("D9:E11") in all of the sheets I use the following VBA refering to the solution here:
Sub Sample()
MoveButton Sheet1, "Button 1", True
End Sub
Sub MoveButton(sh As Worksheet, btnName As String, Optional AllSheets As Boolean)
Dim Range_Position As Range
Dim ws As Worksheet
Set Range_Position = sh.Range("D9:E11")
If AllSheets = True Then
For Each ws In ThisWorkbook.Sheets
With ws.Buttons(btnName)
.Top = Range_Position.Top
.Left = Range_Position.Left
.Width = Range_Position.Width
.Height = Range_Position.Height
.Text = "Button"
End With
Next ws
Else
With sh.Buttons(btnName)
.Top = Range_Position.Top
.Left = Range_Position.Left
.Width = Range_Position.Width
.Height = Range_Position.Height
.Text = "Button"
End With
End If
End Sub
All this works perfectly so far.
However, now it can happen that some of the sheets (For example Sheet3 and Sheet5) do not have the Button 1.
In this case I get runtime error 1004 if I use the above VBA.
Therefore, I am looking for way to check if Button 1 exists in the sheet and if not the VBA should continue to the next sheet.
Something like this before the line With ws.Buttons(btnName):
If Shapes("Button 1").Exists Then
Run VBA
Else
End If
I tried to combine the VBA code above with this function in several ways but could not make it work so far.
Do you have any idea how to solve it?
It can be solved with a parody of "try..catch" construction. It's always bad to use on error check but in VBA not so many options for this.
Function like this should work for you:
Public Function isBtnExists(Optional ws As Worksheet = Nothing, Optional btnName As String = "Button 1") As Boolean
If ws Is Nothing Then
Set ws = ActiveSheet
End If
'turn off errors'
On Error Resume Next
Dim q As Object
'trying to assign button to a variable, if it doesn't exist - error number will appear in global Err object'
Set q = ws.Buttons(btnName)
'by checking the error we know exists button or not'
isBtnExists = (Err.Number = 0)
'dismiss "On Error Resume Next" not really needed here but in some cases VBA can behave weirdly, so it is better to keep it'
On Error GoTo -1
End Function
And in your code will be something like this:
For Each ws In ThisWorkbook.Sheets
If isBtnExists(ws) Then
With ws.Buttons(btnName)
.Top = Range_Position.Top
.Left = Range_Position.Left
.Width = Range_Position.Width
.Height = Range_Position.Height
.Text = "Button"
End With
End If
Next ws
I think either an error handling procedure (as per #AlexandruHapco's answer) or an iteration over buttons:
'....
For Each ws In ThisWorkbook.Sheets
For Each btn In ws.Buttons
If btn.Name = btnName Then
'Do something
Exit For
End If
Next btn
Next ws
'....
I need to view the full contents of a cell in Excel.
Consider the following example:
The text is too large for the cell, so I want to click/hover over the cell and view it's full contents. I initially used the Selection.Validation method to display an input message as shown above. However, the limit is 255 chars for this meaning I get an error on cells with larger contents (I also researched a way for making this bigger but you cannot).
I want the cell and text size to remain the same.
You could use the selection change event to display a shape with the cell value.
Based on code from here
Private Sub worksheet_selectionchange(ByVal Target As Range)
Const ZOOM_CELLS = "zoomCells"
' Range where the cell is "zoomed"
Dim rg As Range
Set rg = Range("D1:D4")
Dim zoomShape As Variant
' Delete zoom shapes
For Each zoomShape In ActiveSheet.Pictures
If zoomShape.Name = ZOOM_CELLS Then
zoomShape.Delete
End If
Next
' Zoom only for defined range
If Intersect(rg, Target) Is Nothing Then Exit Sub
' Zoom only in case one cell is selected
If Target.CountLarge > 1 Then Exit Sub
' no zoom if cell is empty
If Len(Target.Value) = 0 Then Exit Sub
Application.ScreenUpdating = False
Dim oldHeight As Double, oldWraptext As Boolean
With Target
oldHeight = .RowHeight
oldWraptext = .WrapText
' increase cell height and wrap text
.WrapText = True
.EntireRow.AutoFit
' paste it as picture on the sheet
.CopyPicture xlScreen, xlPicture
' restore old row height and wrapt text
.RowHeight = oldHeight
.WrapText = oldWraptext
End With
Application.ActiveSheet.Pictures.Paste.Select
' make pasted picture pretty
With Selection
.Name = ZOOM_CELLS
With .ShapeRange
.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
With .Fill
.ForeColor.SchemeColor = 44
.Visible = msoTrue
.Solid
.Transparency = 0
End With
End With
End With
Target.Select
Application.ScreenUpdating = True
End Sub
You could use the
ActiveCell.AddComment (ActiveCell.Text)
function of your Selection, then resize and reposition it correctly.
After changing the selection delete the old comment and create a new.
Also you would have to make sure that comments are always visible.
I want to automatically insert a picture in cell AH32 depending on value in AB32.
I am able to insert the picture but not depending on the value in AB32. How do I fix this please?
Code:
Sub Picture()
Range("AH32").Select
Dim picname As String
If Range("AB32").Value < 85# Then
picname = "C:\Users\20149308\Desktop\sucess\images" & ".png" 'Link to the Picture
ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Left = Range("AH32").Left
.Top = Range("AH32").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
ElseIf Range("AB32").Value >= 85# Then
picname = "C:\Users\20149308\Desktop\sucess\succ" & ".jpg" 'Link to the Picture
ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Left = Range("AH32").Left
.Top = Range("AH32").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
End If
Range("AH32").Select
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
End Sub
Here is one way of writing it in a more condensed form with some basic error checking.
Option Explicit
Sub Picture()
Application.ScreenUpdating = True
Dim testRange As Range
Dim picname As String
Set testRange = ActiveSheet.Range("AB32")
If IsEmpty(testRange) Then
MsgBox "No value in cell AB32"
Exit Sub
End If
Select Case True
Case Not IsNumeric(testRange.Value2)
MsgBox "Value in cell AB32 is not numeric"
Exit Sub
Case testRange.Value2 < 85#
picname = "C:\Users\20149308\Desktop\sucess\images" & ".png"
Case testRange.Value2 >= 85#
picname = "C:\Users\20149308\Desktop\sucess\succ" & ".jpg"
End Select
On Error GoTo ErrNoPhoto
ActiveSheet.Pictures.Insert(picname).Select
With Selection
.Left = Range("AH32").Left
.Top = Range("AH32").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 80#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
Application.ScreenUpdating = True
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
End Sub
You can do this without any VBA using the Camera. You can find this by selecting File followed by Options and Customize Ribbon and adding the camera icon to your ribbon.
Create a blank worksheet and adjust the column width/row height so each of your pictures will sit within the boundaries of a cell (in my example I'm using B2 and B4).
Select one of these cells and click the camera icon to take a photo of it.
Switch to your reporting sheet and click on it to paste the photo you just took. You'll see a picture of the cell you originally clicked on within a picture frame that you can rotate and resize.
Paste your two pictures into the cells on the blank worksheet. The picture frame on the reporting sheet will now display whichever picture is in the cell you clicked on.
Create a named range using this formula (adjust sheet names to suit):
=IF(Sheet1!$AB$32<85,Sheet2!$B$2,Sheet2!$B$4) - absolute referencing is important here.
I called the range DisplayImage.
Select the picture frame and change the formula in the formula bar to =DisplayImage.
The image will now update based on the value in cell AB32.
I'm trying this for a few hours now, but I can't figure out how to get an image as stationery in my background in Excel 2010. In all ways it seems I just can't get it spread from the top left to bottom right corner.
Can I accomplish this with a macro, or is there some other way to do it?
See the microsoft link
To quote
"In Excel, you can use a picture as a sheet background for display purposes only. A sheet background is not printed and is not retained in an individual worksheet or in an item that you save as a Web page. It is retained only when you publish an entire workbook as a Web page.
Important Because a sheet background is not printed, it cannot be used as a watermark. You can, however, mimic a watermark by inserting a graphic in a header or footer."
This piece of code will let you choose a picture (you can already have one and adapt this code), it will resize the picture to fit the printarea and align it on the top left of the printarea:
Option Explicit
Private Sub Test()
Dim PicLocation As String
Dim MyRange As Range, TargetCell As Range
Set MyRange = Range(ActiveSheet.PageSetup.PrintArea)
Set TargetCell = MyRange.Cells(1, 1)
PicLocation = Application.GetSaveAsFilename("C:\", "Image Files (*.jpg),*.jpg", , "Specify Image Location")
If PicLocation <> "False" Then
ActiveSheet.Pictures.Insert(PicLocation).Select
Else
Exit Sub
End If
With Selection.ShapeRange
.LockAspectRatio = msoTrue
If .Width > .Height Then
.Width = MyRange.Width
If .Height > MyRange.Height Then .Height = MyRange.Height + ActiveSheet.PageSetup.HeaderMargin + ActiveSheet.PageSetup.BottomMargin
Else
.Height = MyRange.Height
If .Width > MyRange.Width Then .Width = MyRange.Width + ActiveSheet.PageSetup.LeftMargin + ActiveSheet.PageSetup.RightMargin
End If
.Left = TargetCell.Left - ActiveSheet.PageSetup.LeftMargin
.Top = TargetCell.Top - ActiveSheet.PageSetup.HeaderMargin
End With
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
End Sub