I have code to change selected text's font to Arial and size 10, it's quite simple:
Sub Arial10()
With Selection.ShapeRange.TextFrame2.TextRange.Font
.name = "Arial"
.Size = 10
End With
End Sub
How can I add to this macro to bold any numbers and dashes ("-") within this selection?
Here it goes....
Sub Arial10()
With Selection.ShapeRange.TextFrame2.TextRange.Font
.Name = "Arial"
.Size = 10
End With
'-----BOLD all numbers and dashes-----
With Selection.ShapeRange.TextFrame2.TextRange
Dim i As Long
For i = 1 To Len(.Text)
If Mid(.Text, i, 1) Like "#" Or _
Mid(.Text, i, 1) = "-" Then
.Characters(i, 1).Font.Bold = True
End If
Next
End With
End Sub
Another take:
Sub Arial10andBoldStuff()
Dim shp As ShapeRange
Dim i As Long
Dim Char As Object
Set shp = Selection.ShapeRange
With shp.TextFrame2.TextRange
With .Font
.Name = "Arial"
.Size = 10
End With
For i = 1 To .Characters.Count
Set Char = .Characters(i, 1)
If IsNumeric(Char) Or Char = "-" Then
Char.Font.Bold = True
End If
Next i
End With
End Sub
Setting the shape to a variable is helpful for getting the Intellisense.
Related
I have an array of shapes created in a for loop and want to assign simple code to each of them as "yes/no" buttons.
The code that creates the array of buttons is as follows:
Dim i As Integer
Dim j As Integer
Dim k As Integer
For i = 1 To 3
For j = 2 To 17
ActiveSheet.Shapes.addshape(msoShapeRectangle, Cells(j, i).Left + 0, _
Cells(j, i).Top + 0, Cells(j, i).Width, Cells(j, i).Height).Select
Next j
Next i
I would like to be able to assign code to each of the shapes as they are created but do not know how. What I want the code to do for each shape looks like the below. I want the shapes to react when clicked and cycle through yes/no/blank text in each of the shapes. The general logic of the code is below
value = value +1
if value = 1, then "yes" and green
if value = 2, then "no" and red
if value = 3, then value = 0 and blank and grey
Thank you in advance for your help
You can do something like this:
Option Explicit
Sub Tester()
Dim i As Long, j As Long, k As Long
Dim addr As String, shp As Shape
For i = 1 To 3
For j = 2 To 17
With ActiveSheet.Cells(j, i)
Set shp = .Parent.Shapes.AddShape(msoShapeRectangle, .Left + 0, _
.Top + 0, .Width, .Height)
With shp.TextFrame2
.VerticalAnchor = msoAnchorMiddle
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
End With
shp.Name = "Button_" & .Address(False, False)
End With
shp.Fill.ForeColor.RGB = RGB(200, 200, 200)
shp.OnAction = "ButtonClick"
Next j
Next i
End Sub
'called from a click on a shape
Sub ButtonClick()
Dim shp As Shape, capt As String, tr As TextRange2
'get a reference to the clicked-on shape
Set shp = ActiveSheet.Shapes(Application.Caller)
Set tr = shp.TextFrame2.TextRange
Select Case tr.Text 'decide based on current button text
Case "Yes"
tr.Text = ""
shp.Fill.ForeColor.RGB = RGB(200, 200, 200)
Case "No"
tr.Text = "Yes"
shp.Fill.ForeColor.RGB = vbGreen
Case ""
tr.Text = "No"
shp.Fill.ForeColor.RGB = vbRed
End Select
End Sub
Just to visualize my idea regarding using the selection change event instead of buttons:
The area that should be the clickable range is named clickArea - in this case B2:D17.
Then you put this code in the according sheet module
Option explicit
Private Const nameClickArea As String = "clickArea"
Private Enum bgValueColor
neutral = 15921906 'gray
yes = 11854022 'green
no = 11389944 'red
End Enum
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'whenever user clicks in the "clickArea" the changeValueAndColor macro is triggered
If Not Intersect(Target.Cells(1, 1), Application.Range(nameClickArea)) Is Nothing Then
changeValueAndColor Target.Cells(1, 1)
End If
End Sub
Private Sub changeValueAndColor(c As Range)
'this is to deselect the current cell so that user can select it again
Application.EnableEvents = False: Application.ScreenUpdating = False
With Application.Range(nameClickArea).Offset(50).Resize(1, 1)
.Select
End With
'this part changes the value and color according to the current value
With c
Select Case .Value
Case vbNullString
.Value = "yes"
.Interior.Color = yes
Case "yes"
.Value = "no"
.Interior.Color = no
Case "no"
.Value = vbNullString
.Interior.Color = neutral
End Select
End With
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub
And this is how it works - with each click on one of the cells value and background color are changed. You have to click on the image to start anmimation.
To reset everything I added a hyperlink that calls the reset action (and refers to itself)
Add this code to the sheets module
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
clearAll
End Sub
Private Sub clearAll()
With Application.Range(nameClickArea)
.ClearContents
.Interior.Color = neutral
End With
End Sub
I have a column in a table that will contain entire phrases with difficult words ("hypothetical exemplification of those akiophrastic words"). I have a list of most words that I expect will be used there.
I found a great solution here but it doesn't quite match my usecase. It works if you want to choose the content of your cell from a list of choices. I want to be able to get suggestions for the currently-typed word within the cell. So I write "hypoth" and click "hypothetical" from the dropdown, then I hit spacebar and start writing "exem" and want to get suggestions for that as well, and so on.
I will try changing the VBA code provided in my hyperlink above but I'm not sure I'll be successful. I'm open to any suggestion. It can also involve userforms although I doubt there is a way using them.
EDIT: On request, I'm summarizing the linked tutorial and posting its code.
It makes you create a Combo Box from the developer tools tab and name it TempCombo.
In the code for the worksheet, where the box is located, you write the following code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2020/01/16
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim xArr
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
If .ListFillRange = "" Then
xArr = Split(xStr, ",")
Me.TempCombo.List = xArr
End If
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
Here's a very basic example using a text box (txt1) and a listbox (lstMatches) on a worksheet:
Option Explicit
Dim suspend As Boolean
Private Sub lstMatches_Click()
Dim word, pos As Long
word = Me.lstMatches.Value
suspend = True
'try to replace the last "word" (or part of word) with the selected word
pos = InStrRev(Me.txt1.Text, " ")
If pos > 0 Then
Me.txt1.Text = Left(Me.txt1.Text, pos) & " " & word
Else
Me.txt1.Text = word
End If
Me.txt1.Activate
suspend = False
End Sub
Private Sub txt1_Change()
Dim txt As String, arr, last As String, allWords, r As Long
If suspend Then Exit Sub 'don't respond to programmatic changes
txt = Trim(Me.txt1.Text)
If Len(txt) = 0 Then 'is there any text?
Me.lstMatches.Clear
Exit Sub
End If
arr = Split(txt, " ")
last = arr(UBound(arr)) 'get the last word
If Len(last) > 1 Then
allWords = Me.Range("words").Value 'get the words list
Me.lstMatches.Clear
For r = 1 To UBound(allWords)
If allWords(r, 1) Like last & "*" Then 'match on "starts with"
Me.lstMatches.AddItem allWords(r, 1)
End If
Next r
End If
End Sub
Using the linked code from my OP and Tim Williams's excellent code, this is the result I got to. To use this, you will have to adapt some lines. There were some really odd bugs which I fixed by adapting some parts. Also added control functionality with Return (+Shift), up and down keys.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xText As OLEObject
Dim xStr As String
Dim xList As OLEObject
Dim xWs As Worksheet
Dim xArr
Dim ListTarget As Range
' Suggestion box placement
Set ListTarget = Target.Offset(2, 1)
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xText = xWs.OLEObjects("txt1")
Set xList = xWs.OLEObjects("lstMatches")
' Every click lets the boxes disappear.
With xText
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
With xList
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
' Restrict where you want this functionality in your sheet here
If Target.Validation.Type = 3 And Target.column = 10 And Target.row > 4 Then
Target.Validation.InCellDropdown = False
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xText
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 200 ' Size of text box
.Height = Target.Height + 5 ' Make it a little taller for better readability
.ListFillRange = ""
'If .ListFillRange = "" Then
'xArr = Split(xStr, ",")
'Me.TempCombo.list = xArr
'End If
.LinkedCell = Target.Address
End With
With xList
.Visible = True
.Left = ListTarget.Left
.Top = ListTarget.Top
.Width = ListTarget.Width + 200 ' Size of suggestions box
.Height = ListTarget.Height + 100
If .ListFillRange = "" Then 'This loop fills the suggestions with the list from the validation formula, unless already changed by input
xArr = Split(xStr, ",")
xList.ListFillRange = xArr
End If
End With
xText.Activate
Me.lstMatches.Locked = False ' It randomly locked for me, just in case.
' The following two lines fix an obscure bug that made the suggestions un-clickable at random.
ActiveWindow.SmallScroll ToLeft:=1
ActiveWindow.SmallScroll ToRight:=1
End If
End Sub
Private Sub lstMatches_Click()
Dim word, pos As Long
word = Me.lstMatches.value
suspend = True ' disables the text change function for programmatic changes
'try to replace the last "word" (or part of word) with the selected word
pos = InStrRev(Me.txt1.text, " ")
If pos > 0 Then
Me.txt1.text = Left(Me.txt1.text, pos) & word
Else
Me.txt1.text = word
End If
Me.txt1.Activate
suspend = False
End Sub
Private Sub txt1_Change()
Dim txt As String, arr, last As String, allWords, r As Long
Dim data_lastRow As Long
data_lastRow = Worksheets("my_data").Cells(2, 5).End(xlDown).row
If suspend Then Exit Sub 'don't respond to programmatic changes
txt = Trim(Me.txt1.text)
If Len(txt) = 0 Then
Me.lstMatches.Clear
Exit Sub
End If
arr = Split(txt, " ")
last = arr(UBound(arr))
If Len(last) > 1 Then
allWords = Worksheets("my_data").Range("E2:E" & CStr(data_lastRow)).value 'get the words list
Me.lstMatches.Clear
For r = 1 To UBound(allWords)
If allWords(r, 1) Like last & "*" Then 'match on "starts with"
Me.lstMatches.AddItem allWords(r, 1)
If Me.lstMatches.ListCount = 15 Then Exit Sub ' limiting it to 15 suggestions
End If
Next r
End If
End Sub
Private Sub txt1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 13
If Shift = 0 Then
Application.ActiveCell.Offset(1, 0).Activate
Else
Application.ActiveCell.Offset(-1, 0).Activate
End If
Case vbKeyDown
Application.ActiveCell.Offset(1, 0).Activate
Case vbKeyUp
Application.ActiveCell.Offset(-1, 0).Activate
Case vbKeyLeft
Application.ActiveCell.Offset(0, -1).Activate
End Select
End Sub
How can I display the copied comment FONT the same as original comment (e.g still wants part of the comment bold and underlined)?
Sub Comments()
Dim X As Long, RngName As String, curwks As Worksheet
Sheet1.Select
Set curwks = ActiveSheet
If curwks.Comments.Count Then
Sheet2.Select
Range("A1").Select
On Error Resume Next
For X = 1 To curwks.Comments.Count
With curwks.Comments.Item(X)
Sheet2.Range("A1").Offset(X, 0).Resize(1, 1) = _
Array(.Text)
End With
Next
End If
End Sub
This is not a full solution because the Underline portion doesn't work for some reason, possibly a bug. If I get a chance I'll look into it, but something might be better than nothing.
Sub Comments()
Dim X As Long, i As Long
If Sheet1.Comments.Count Then
For X = 1 To Sheet1.Comments.Count
With Sheet2.Range("A1").Offset(X, 0)
.Clear
.Font.Bold = False
.Font.Underline = False
.Value = Sheet1.Comments.Item(X).Text
End With
With Sheet1.Comments.Item(X).Shape.TextFrame
For i = 1 To .Characters.Count
If .Characters(i, 1).Font.Bold = True Then
Sheet2.Range("A1").Offset(X, 0).Characters(i, 1).Font.Bold = True
End If
If .Characters(i, 1).Font.Underline = True Then
Sheet2.Range("A1").Offset(X, 0).Characters(i, 1).Font.Underline = True
End If
Next i
End With
Next
End If
End Sub
I would like to make a relocation (cut & paste) for quite a few images.
The Shape ID changes 1 by one, the same as the Selection. name value
The target cells also change by 1 value, as you can see.
My code looks as follows:
Private Sub ChamberImage_Click()
ActiveSheet.Shapes("Textbox_Chamber1").Cut
ActiveSheet.Range("AA70").PasteSpecial
Selection.Name = "Textbox_Chamber1"
ActiveSheet.Shapes("Textbox_Chamber2").Cut
ActiveSheet.Range("AA71").PasteSpecial
Selection.Name = "Textbox_Chamber2"
ActiveSheet.Shapes("Textbox_Chamber3").Cut
ActiveSheet.Range("AA72").PasteSpecial
Selection.Name = "Textbox_Chamber3"
ActiveSheet.Shapes("Textbox_Chamber4").Cut
ActiveSheet.Range("AA73").PasteSpecial
Selection.Name = "Textbox_Chamber4"
ActiveSheet.Shapes("Textbox_Chamber5").Cut
ActiveSheet.Range("AA74").PasteSpecial
Selection.Name = "Textbox_Chamber5"
ActiveSheet.Shapes("Textbox_Chamber6").Cut
ActiveSheet.Range("AA75").PasteSpecial
Selection.Name = "Textbox_Chamber6"
ActiveSheet.Shapes("Textbox_Chamber7").Cut
ActiveSheet.Range("AA76").PasteSpecial
Selection.Name = "Textbox_Chamber7"
ActiveSheet.Shapes("Textbox_Chamber8").Cut
ActiveSheet.Range("AA77").PasteSpecial
Selection.Name = "Textbox_Chamber8"
ActiveSheet.Shapes("Textbox_Chamber9").Cut
ActiveSheet.Range("AA78").PasteSpecial
Selection.Name = "Textbox_Chamber9"
End Sub
How can I write it much smarter? Is it some loop on it?
Without the cut/paste:
Private Sub ChamberImage_Click()
Dim i as long , shp, ws as worksheet
set ws = activesheet
For i = 1 to 9
set shp = ws.Shapes("Textbox_Chamber" & i)
with ws.Range("AA70").Offset(i - 1 , 0)
shp.top = .Top
shp.left = .Left
end with
Nexti
End Sub
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.