Resize/ position shapes in PowerPoint presentation - excel

I have old code I am repurposing for a more general use.
I have a PowerPoint presentation I want to paste specific image files into, create a new slide and then repeat until all the variable names in column A are finished.
It finds the image name in a specific file location, builds the name based on a left of variable name value, variable name values (column A) and right of variable name value. Ex. ("Device" "23" "for generic product line").
After finding this image name, it takes that image and inserts it onto a slide, resizes and positions it to the left, then finds another comparison image, places that on the same slide and resizes and positions it to the right.
The resizing and positioning no longer works as it should. It seems like the image is not being treated as a shape. I have that the first image is shape(2) from previous experimentation as there is some clipart on the slides that counts as a shape. I then had that shape(3) was image 2 for the same reason.
Sub Export_To_PowerPoint_JAH()
' Keyboard Shortcut: Ctrl+Shift+M
Dim Shape1 As PowerPoint.Shape
Dim Shape2 As PowerPoint.Shape
Dim objSlide As Slide
Dim New_Slide As Slide
Dim pptLayout As CustomLayout
Dim PP As PowerPoint.Application
Dim PPpres As PowerPoint.Presentation
'Create a PP application and make it visible
Set PP = New PowerPoint.Application
PP.Visible = msoCTrue
'Open the presentation you wish to copy to
'Opens the Template
Set PPpres = PP.Presentations.Open("A file path name to a template")
i = 7
Pre_Left = Range("H2")
Pre_Right = Range("H4")
Post_Left = Range("K2")
Post_Right2 = Range("K4")
Do
Set objSlide = PPpres.Slides(i - 5)
Set Title = PPpres.Slides(i - 5)
If Cells(i, 1) = "" Then
Exit Do
Else: End If
Variable_Name = Cells(i, 1)
'Searches Image Bank Folder for pre and post file names
If Not Range("H2") = "" Then
Image_Name_Pre = Pre_Left & " " & Variable_Name & " " & Pre_Right
Else
Image_Name_Pre = Variable_Name & " " & Pre_Right
End If
If Not Range("K2") = "" Then
Image_Name_Post = Post_Left & " " & Variable_Name & " " & Post_Right2
Else
Image_Name_Post = Variable_Name & " " & Post_Right2
End If
Set Shape1 = objSlide.Shapes.AddPicture(Range("B5") & Image_Name_Pre, msoCTrue, msoCTrue, 100, 100)
objSlide.Shapes.Item(2).Width = 300
objSlide.Shapes.Item(2).Height = 400
objSlide.Shapes.Item(2).Top = 140
objSlide.Shapes.Item(2).Left = 90
Set Shape2 = objSlide.Shapes.AddPicture(Range("B5") & Image_Name_Post, msoCTrue, msoCTrue, 100, 100)
objSlide.Shapes.Item(3).Width = 300
objSlide.Shapes.Item(3).Height = 400
objSlide.Shapes.Item(3).Top = 140
objSlide.Shapes.Item(3).Left = 500
Title.Shapes.Title.TextFrame.TextRange.Text = Cells(i, 3) & " Pre (Left) : " & Cells(i, 3) & " Post (Right) Offset=" & Cells(i, 4)
'Create new slide
Set New_Slide = PPpres.Slides.Add(PPpres.Slides.Count + 1, PpSlideLayout.ppLayoutObject)
'ActivePresentation.Slides.Add Index:=ActivePresentation.Slides.Count + 1, Layout:=ppLayoutCustom
i = i + 1
Loop
End Sub

Assuming that the shape you're after will be the n'th shape on a slide isn't a good idea, and in your case, there's no need to do so. This:
Set Shape1 = objSlide.Shapes.AddPicture(Range("B5") & Image_Name_Pre, msoCTrue, msoCTrue, 100, 100)
gives you a reference to the newly inserted image in the variable Shape1, so you can do this:
With Shape1
.Width = 300
.Height = 400
.Top = 140
.Left = 90
End With
Likewise for Shape2.
Also, you do this:
Set Title = PPpres.Slides(i - 5)
Two problems here:
1) You haven't declared the variable Title, and
2) It's not good practice to use object/method/property names as variable names.
Instead:
Dim oTitle as Slide
Set oTitle = PPpres.Slides(i - 5)

Related

Need help using VBA to insert hyperlinks in excel to specified pictures on my computer

I have 600+ pictures in a folder on my computer and I want to link each one to a different cell in an excel file using vba instead of going through and linking each one manually. I'm not very good at vba but the end goal is a code that can go down the line in excel and pull the designated picture from my files and link it and then go to the next.
The code I have so far is partially going off another post I saw on here and it's just trying to do the first step of inserting the first picture but I am having trouble with it:
Dim Picture_1 As String
With ActiveSheet.Pictures.Insert("X:\roena10\Q ear crack pictures")
.Left = ActiveSheet.Range("photograph").Left + 2
.Top = ActiveSheet.Range("photograph").Top + 2
Picture_1 = .Name
End With
ActiveSheet.Pictures(profile).Select
With Selection.ShapeRange
.LockAspectRatio = msoFalse
.Width = 20
.Height = 20
End With
Any help is appreciated!
Try this code:
Sub AddImages()
Const path = "c:\test\", W = 20, H = 20, h_gap = 5
Dim img As Shape, cl As Range, ws As Worksheet
Dim fname As String, ext As String, pos As Integer, T As Long, L As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
Set cl = ws.Range("B1")
fname = Dir(path & "*", vbNormal)
Do While Len(fname) > 0
pos = InStrRev(fname, ".")
ext = vbNullString
If pos > 0 Then ext = LCase(Mid(fname, pos + 1))
Select Case ext
Case "jpg", "png", "bmp" 'and so on
With cl
T = .Top + 2
L = .Left + 2
.EntireRow.RowHeight = H + h_gap
End With
Set img = ws.Shapes.AddPicture(Filename:=path & fname, _
LinkToFile:=msoTrue, SaveWithDocument:=True, _
Left:=L, Top:=T, Width:=-1, Height:=-1)
img.LockAspectRatio = msoTrue
img.Height = H
With img.Line
.Visible = msoTrue
.ForeColor.RGB = vbBlack
.Transparency = 0
End With
ws.Hyperlinks.Add Anchor:=img, Address:=path & fname
T = T + H + h_gap
Set cl = cl.Offset(1)
End Select
fname = Dir
Loop
End Sub
Screenshot

How to dynamically update scatter chart series with VBA?

I have a worksheet with about 30 charts I want to update dynamically with a VBA macro. I have some issues in handling the series, but I can't find out what's wrong.
The code should run through several charts (only 3 in the following code), clear old contents, and add 6 new series with data taken from the spreadsheet. On the contrary, it doesn't delete the old series and, at each run, adds them again with a new one, then quits with a "Parameter not valid" error on line 22. I have been struggling on this for a couple of weeks now, and the most frustrating part is that the code is basically a copy+paste from another project, which works fine.
Here's the code:
Public Sub Refresh_NB_Graphs()
Dim cht As Chart
Dim chtObj As ChartObject
Dim vi As Integer
Dim s As Object
Dim j As Integer
Dim k As Integer
Dim seriesIndex As Integer
Dim xRange As Range
Dim yRange As Range
'Application.ScreenUpdating = False
On Error GoTo Errorcatch
'Graph fetching and update cycle
For vi = 1 To 3
Set chtObj = Sh_NBGain.ChartObjects("Ch_Gain_Vs" & CStr(vi))
Set cht = chtObj.Chart
' Adding or removing this section makes no difference -------
For Each s In cht.SeriesCollection
s.Delete
Next s
' -----------------------------------------------------------
cht.ChartArea.ClearContents
'Format Font Type and Size
cht.ChartType = xlXYScatterLinesNoMarkers ' scatter plot
cht.ChartArea.Format.TextFrame2.TextRange.Font.Name = "Arial"
cht.ChartArea.Format.TextFrame2.TextRange.Font.Size = 14
cht.HasTitle = False ' No chart title
' Add series: data origin in Sh_NBGainProcess
seriesIndex = 0
For j = 0 To 5
seriesIndex = seriesIndex + 1
cht.SeriesCollection.NewSeries
1 cht.SeriesCollection(seriesIndex).Name = CStr(Sh_Vars.Range("A8").Offset(j, 0).Value)
Set xRange = Sh_NBGainProcess.Range("C42:C1642").Offset(1600 * (vi - 1), 20 * j)
Set yRange = Sh_NBGainProcess.Range("D42:D1642").Offset(1600 * (vi - 1), 20 * j)
10 cht.SeriesCollection(seriesIndex).XValues = "='" & Sh_NBGainProcess.Name & "'!" & xRange.Address
20 cht.SeriesCollection(seriesIndex).Values = "='" & Sh_NBGainProcess.Name & "'!" & yRange.Address
22 With cht.SeriesCollection(seriesIndex)
23 Debug.Print seriesIndex
30 .Format.Line.Weight = 2.25
40 .Format.Line.Visible = msoTrue
50 .Format.Line.ForeColor.RGB = ECOPalette(j) ' Array with defined colors
60 .MarkerStyle = xlMarkerStyleNone
End With
Next j
'.....................
Next vi
End Sub
Can anybody help?
Thanks!
Had to rework the code a bit, but now it's fine:
Dim cht As Chart
Dim s As Series
Dim vi As Integer
Dim j As Integer
Dim xRange As Range
Dim yRange As Range
'Application.ScreenUpdating = False
On Error GoTo Errorcatch
'Graph fetching and update cycle
For vi = 1 To 3
' Gain charts (Vs 1 to 3) ***********************************************************************************************************
Set cht = Sh_NBGain.ChartObjects("Ch_Gain_Vs" & CStr(vi)).Chart
' Clear existing data
For Each s In cht.SeriesCollection
s.Delete
Next s
cht.ChartArea.ClearContents
cht.ChartType = xlXYScatterLinesNoMarkers ' scatter plot
' Add series: data origin in Sh_NBGainProcess
For j = 0 To 5
If Not Sh_NBGainProcess.Range("C42").Offset(1601 * (vi - 1), 20 * j).Value = "" Then
10 Set s = cht.SeriesCollection.NewSeries
40 s.Name = CStr(Sh_Vars.Range("A8").Offset(j, 0).Value)
50 Set xRange = Sh_NBGainProcess.Range("C42:C1642").Offset(1601 * (vi - 1), 20 * j)
60 Set yRange = Sh_NBGainProcess.Range("D42:D1642").Offset(1601 * (vi - 1), 20 * j)
90 s.XValues = "='" & Sh_NBGainProcess.Name & "'!" & xRange.Address
100 s.Values = "='" & Sh_NBGainProcess.Name & "'!" & yRange.Address
110 With s
130 .Format.Line.Weight = 2.25
140 .Format.Line.Visible = msoTrue
150 .Format.Line.ForeColor.RGB = ECOPalette(j)
160 .MarkerStyle = xlMarkerStyleNone
End With
End If
Next j
I think that the main issue was due to the use of the series collection indexing, which was somehow misbehaving (I still don't understand why). By referring directly to the series object when created, with Set s = cht.SeriesCollection.NewSeries, things go fine.

Excel incorrectly placing images

I'm trying to help out a coworker with her VBA in Excel 2013. It looks like the macro is successfully pulling in the images from the designated path, but it dumps every single photo into cell A1.
Any thoughts?
Sub DeleteAllPictures()
Dim S As Shape
For Each S In ActiveSheet.Shapes
Select Case S.Type
Case msoLinkedPicture, msoPicture
S.Delete
End Select
Next
End Sub
Sub UpdatePictures()
Dim R As Range
Dim S As Shape
Dim Path As String, FName As String
'Setup the path
Path = "G:\In Transit\Carlos\BC Website images"
'You can read this value also from a cell, e.g.:
'Path = Worksheets("Setup").Range("B1")
'Be sure the path has a trailing backslash
If Right(Path, 1) <> "\" Then Path = Path & "\"
'Visit each used cell in column A
For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp))
'Try to get the shape
Set S = GetShapeByName(R)
'Found?
If S Is Nothing Then
'Find the picture e.g. "C:\temp\F500.*"
FName = Dir(Path & R & ".*")
'Found?
If FName <> "" Then
Set S = InsertPicturePrim(Path & FName, R)
End If
End If
If Not S Is Nothing Then
'Show the error if the name did not match the cell
If S.Name <> R Then R.Interior.Color = vbRed
With R.Offset(0, 1)
'Move the picture to the cell on the right side
S.Top = .Top
S.Left = .Left
'Resize it
S.Width = .Width
'Remove the aspect ratio by default if necessary
'S.LockAspectRatio = False
If S.LockAspectRatio Then
'Make it smaller to fit the cell if necessary
If S.Height > .Height Then S.Height = .Height
Else
'Stretch the picture
S.Height = .Height
End If
End With
'Move it behind anything else
S.ZOrder msoSendToBack
Else
R.Offset(0, 1) = "No picture available"
End If
Next
End Sub
Private Function GetShapeByName(ByVal SName As String) As Shape
'Return the shape with SName, Nothing if not exists
On Error Resume Next
Set GetShapeByName = ActiveSheet.Shapes(SName)
End Function
Private Function InsertPicturePrim(ByVal FName As String, ByVal SName As String) As Shape
'Inserts the picture, return the shape, Nothing if failed
Dim P As Picture
On Error Resume Next
'Insert the picture
Set P = ActiveSheet.Pictures.Insert(FName)
'code to resize
With P
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Set P = Nothing
'code to resize
'Success?
If Not P Is Nothing Then
'Return the shape
Set InsertPicturePrim = P.ShapeRange(1)
'Rename it, so we can easily find it later
P.Name = SName
End If
End Function
The short answer is: your macro is inserting the picture at the selected cell. Change the selection before the insert line, and you should get it inserted at each row.
Here in this example, I am selecting the cell to the left of the cell you are pulling the name value from.
If FName <> "" Then
'select the cell 1 to the left of the cell containing the image name
R.Offset(0,-1).select
Set S = InsertPicturePrim(Path & FName, R)
End If

VBA: Modify chart data range

My "Chart data range" is ='sheet1'!$A$1:$Z$10. I'd like to make a VBA macro (or if anybody knows a formula I can use, but I couldn't figure one out) to increase the ending column of the range for chart1 by 1 every time I run the macro. So essentially:
chart1.endCol = chart1.endCol + 1
What is the syntax for this using ActiveChart or is there a better way?
Offset function dynamic range makes it possible.
Sample data
Steps
Define a dynamic named range
=OFFSET(Sheet1!$A$2,,,1,COUNTA(Sheet1!$A$2:$Z$2)) and give it a
name mobileRange
Right Click on Chart
Click on Select Data
This screen will come
Click on Edit under Legend Entries.(mobiles is selected)
change the Series value to point to mobileRange named range.
Now if data for future months are added to mobile sales it will automatically reflect in chart.
Assuming that you want to expand the range (by adding one extra column) to add one more observation for each series in you diagram (and not to add a new series), you could use this code:
Sub ChangeChartRange()
Dim i As Integer, r As Integer, n As Integer, p1 As Integer, p2 As Integer, p3 As Integer
Dim rng As Range
Dim ax As Range
'Cycles through each series
For n = 1 To ActiveChart.SeriesCollection.Count Step 1
r = 0
'Finds the current range of the series and the axis
For i = 1 To Len(ActiveChart.SeriesCollection(n).Formula) Step 1
If Mid(ActiveChart.SeriesCollection(n).Formula, i, 1) = "," Then
r = r + 1
If r = 1 Then p1 = i + 1
If r = 2 Then p2 = i
If r = 3 Then p3 = i
End If
Next i
'Defines new range
Set rng = Range(Mid(ActiveChart.SeriesCollection(n).Formula, p2 + 1, p3 - p2 - 1))
Set rng = Range(rng, rng.Offset(0, 1))
'Sets new range for each series
ActiveChart.SeriesCollection(n).Values = rng
'Updates axis
Set ax = Range(Mid(ActiveChart.SeriesCollection(n).Formula, p1, p2 - p1))
Set ax = Range(ax, ax.Offset(0, 1))
ActiveChart.SeriesCollection(n).XValues = ax
Next n
End Sub
Assuming that you only run the macro with a Chart Selected, my idea is to alter the range in the formula for each Series. You can of cause change to apply to all Charts in a Worksheet.
UPDATE: Have changed code to accommodate multiple series with screenshots
Formatting of new series string needs to include apostrophes around the worksheet name (already changed below): aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address. Also, if looking to change rows rather than columns, change the offset to Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(1, 0)) or as needed. Can also include oRng.Offset(1, 0) for the first element in the range to adjust the start position of the series: Set oRng = oRng.Worksheet.Range(oRng.Offset(1, 0), oRng.Offset(1, 0))
Sub ChartRangeAdd()
On Error Resume Next
Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
Dim i As Long, s As Long
Dim oRng As Range, sTmp As String, sBase As String
Set oCht = ActiveSheet.ChartObjects(1).Chart
oCht.Select
For s = 1 To oCht.SeriesCollection.count
sTmp = oCht.SeriesCollection(s).Formula
sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
aFormulaNew = Array()
ReDim aFormulaNew(UBound(aFormulaOld))
' Process all series in the formula
For i = 0 To UBound(aFormulaOld)
Set oRng = Range(aFormulaOld(i))
' Attempt to put the value into Range, keep the same if it's not valid Range
If Err.Number = 0 Then
Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address
Else
aFormulaNew(i) = aFormulaOld(i)
Err.Clear
End If
Next i
sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
oCht.SeriesCollection(s).Formula = sTmp
sTmp = ""
Next s
Set oCht = Nothing
End Sub
Sample data - Initial
After first run:
Second Run:
Third Run:
PatricK's answer works great with some minor adjustments:
Formatting of new series string needs to include apostrophes around the worksheet name on line 22 aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address. Also, if looking to change rows rather than columns, change the offset on line 21 to Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(1, 0)) or as needed. Can also include oRng.Offset(1, 0) for the first element in the range to adjust the start position of the series: Set oRng = oRng.Worksheet.Range(oRng.Offset(1, 0), oRng.Offset(1, 0))
Sub ChartRangeAdd()
On Error Resume Next
Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
Dim i As Long, s As Long
Dim oRng As Range, sTmp As String, sBase As String
Set oCht = ActiveSheet.ChartObjects(1).Chart
oCht.Select
For s = 1 To oCht.SeriesCollection.count
sTmp = oCht.SeriesCollection(s).Formula
sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
aFormulaNew = Array()
ReDim aFormulaNew(UBound(aFormulaOld))
' Process all series in the formula
For i = 0 To UBound(aFormulaOld)
Set oRng = Range(aFormulaOld(i))
' Attempt to put the value into Range, keep the same if it's not valid Range
If Err.Number = 0 Then
Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address
Else
aFormulaNew(i) = aFormulaOld(i)
Err.Clear
End If
Next i
sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
oCht.SeriesCollection(s).Formula = sTmp
sTmp = ""
Next s
Set oCht = Nothing
End Sub
PatricK and sirbedevire got me started with this fairly well. Now, I'm trying to consolidate it into a separate sub I can reference to process multiple charts. Unfortunately, I'm missing something in the referencing so it's not making the updates (and not producing an error).
1st sub using 2nd sub
If ws < numTabs - 1 Then
chartUpdate Summary, Chart_BidsByMonth ' Name of sheet with target chart, Name of target chart
chartUpdate Summary, Chart_SoldByMonth ' Name of sheet with target chart, Name of target chart
End If
2nd sub processing chart range update
Sub chartUpdate(shtRef As Variant, chtRef As Variant)
On Error Resume Next
Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
Dim n As Long, s As Long
Dim oRng As Range, sTmp As String, sBase As String
' Update chart referenced as chtRef '
Set oCht = Sheets(""" & shtRef & """).ChartObjects(""" & chtRef """).Chart
oCht.Select
For s = 1 To oCht.SeriesCollection.Count
sTmp = oCht.SeriesCollection(s).Formula
sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
aFormulaNew = Array()
ReDim aFormulaNew(UBound(aFormulaOld))
' Process all series in the formula
For n = 0 To UBound(aFormulaOld)
Set oRng = Range(aFormulaOld(n))
' Attempt to put the value into Range, keep the same if it's not valid Range
If Err.Number = 0 Then
Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
aFormulaNew(n) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address
Else
aFormulaNew(n) = aFormulaOld(i)
Err.Clear
End If
Next n
sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
oCht.SeriesCollection(s).Formula = sTmp
sTmp = ""
Next s
Set oCht = Nothing
' End charts update '
End Sub

Insert text into the background of a cell

I am looking for a way to insert text into the background of a cell, so that I can still enter numbers on top of that text - similar to a watermark except for an individual cell. Any ways to do this, preferably without using a macro (but open to these solutions as well)?
Similar to Andrews post, this is the VBA version which formats the shape correctly and also allows direct selecting of cells.
Code MODULE:
Sub watermarkShape()
Const watermark As String = "watermark"
Dim cll As Range
Dim rng As Range
Dim ws As Worksheet
Dim shp As Shape
Set ws = Sheet1
Set rng = ws.Range("A1:F10") 'Set range to fill with watermark
Application.ScreenUpdating = False
For Each shp In ws.Shapes
shp.Delete
Next shp
For Each cll In rng
Set shp = ws.Shapes.AddShape(msoShapeRectangle, 5, 5, 5, 5)
With shp
.Left = cll.Left
.Top = cll.Top
.Height = cll.Height
.Width = cll.Width
.Name = cll.address
.TextFrame2.TextRange.Characters.Text = watermark
.TextFrame2.TextRange.Font.Name = "Tahoma"
.TextFrame2.TextRange.Font.Size = 8
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.TextFrame2.WordWrap = msoFalse
.TextFrame.Characters.Font.ColorIndex = 15
.TextFrame2.TextRange.Font.Fill.Transparency = 0.35
.Line.Visible = msoFalse
' Debug.Print "'SelectCell (""" & ws.Name & """,""" & cll.address & """)'"
.OnAction = "'SelectCell """ & ws.Name & """,""" & cll.address & """'"
With .Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.Transparency = 1
.Solid
End With
End With
Next cll
Application.ScreenUpdating = True
End Sub
Sub SelectCell(ws, address)
Worksheets(ws).Range(address).Select
End Sub
UPDATE:
the example below assigns a watermark of the cell address to odd rows and leaves the even rows as the constant watermark. This is an exaple based on my comment that any cell can be assigned any watermark text based on whatever conditons you want.
Option Explicit
Sub watermarkShape()
Const watermark As String = "watermark"
Dim cll As Range
Dim rng As Range
Dim ws As Worksheet
Dim shp As Shape
Set ws = Sheet1
Set rng = ws.Range("A1:F10") 'Set range to fill with watermark
Application.ScreenUpdating = False
For Each shp In ws.Shapes
shp.Delete
Next shp
For Each cll In rng
Set shp = ws.Shapes.AddShape(msoShapeRectangle, 5, 5, 5, 5)
With shp
.Left = cll.Left
.Top = cll.Top
.Height = cll.Height
.Width = cll.Width
.Name = cll.address
If cll.Row Mod 2 = 1 Then
.TextFrame2.TextRange.Characters.Text = cll.address
Else
.TextFrame2.TextRange.Characters.Text = watermark
End If
.TextFrame2.TextRange.Font.Name = "Tahoma"
.TextFrame2.TextRange.Font.Size = 8
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.TextFrame2.WordWrap = msoFalse
.TextFrame.Characters.Font.ColorIndex = 15
.TextFrame2.TextRange.Font.Fill.Transparency = 0.35
.Line.Visible = msoFalse
' Debug.Print "'SelectCell (""" & ws.Name & """,""" & cll.address & """)'"
.OnAction = "'SelectCell """ & ws.Name & """,""" & cll.address & """'"
With .Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.Transparency = 1
.Solid
End With
End With
Next cll
Application.ScreenUpdating = True
End Sub
Sub SelectCell(ws, address)
Worksheets(ws).Range(address).Select
End Sub
You can use a custom number format (select the cell(s), hit Ctrl+1, number formats, custom) to specify a light-grey text to display when the cell value is 0 - Color15 makes a nice watermark color:
[Black]000000;;[Color15]"(order number)";#
No messy shapes, no VBA, and the watermark disappears when the value is actually filled up.
And if you absolutely need to do it in VBA, then you can easily write a function that builds the format string based on some parameters:
Public Function BuildWatermarkFormat(ByVal watermarkText As String, Optional ByVal positiveFormat As String = "General", Optional ByVal negativeFormat As String = "General", Optional ByVal textFormat As String = "General") As String
BuildWatermarkFormat = positiveFormat & ";" & negativeFormat & ";[Color15]" & Chr(34) & watermarkText & Chr(34) & ";" & textFormat
End Function
And then you can do:
myCell.NumberFormat = BuildWatermarkFormat("Please enter a value")
myCell.Value = 0
And you can still supply custom formats for positive/negative values as per your needs; the only thing is that 0 is reserved for "no value" and triggers the watermark.
myCell.NumberFormat = BuildWatermarkFormat("Please enter a value", "[Blue]#,##0.00_)", "[Red](#,##0.00)")
myCell.Value = -25
Select the Cell where you want to make the Background.
Click "Insert" and insert a rectangular Shape in that location.
Right click on the shape - select "Format Shape"
Goto "Fill" and select "Picture or texture fill"
Goto “Insert from File” option
Select the picture you want to make water-mark
Picture will appear at the place of rectangular shape
Now click on the picture “right click” and select Format Picture
Goto “Fill” and increase the transparency as required to look it like a “Water Mark” or light beckground
This will get printed also.
taken from here
Type your text in a cell anywhere.
Copy it and it will be saved on the clipboard.
Insert a rectangular shape anywhere.
Right click and choose "Send to back".
This will make sure it will be at the background.
Right click and "Format Shape".
Do to tab "Fill" and click on "picture or texture fill".
At the "insert from" choose "clipboard".
Now whatever text you have copied onto your clipboard will be in the rectangular shape.
Resize the shape to fit the cell(s) you desired.
Adjust however you like for example remove the rectangular lines, add shadow, change font, remove background etc.

Resources