I have nine cells in a range that correspond with nine different text box controls on a userform.
Below are the current If statements for two of the cells and the corresponding text boxes when the userform activates.
If wsCalc.Range("CCBalance1") > 0 Then
With RiskCalc.CCBal1
.Visible = True
.Value = Format(wsCalc.Range("CCBalance1"), "Currency")
End With
End If
If wsCalc.Range("CCBalance2") > 0 Then
With RiskCalc.CCBal2
.Visible = True
.Value = Format(wsCalc.Range("CCBalance2"), "Currency")
End With
End If
Below is the For loop I was thinking of using. I have a feeling I am nowhere near close to how this should work.
For Each Cell In wsCalc.Range("CCBalance1:CCBalance9")
'I believe this will choose the first cell in the range named above
If Cell.Offset(0, 0) > 0 Then
With RiskCalc.CCBal1
.Visible = True
.Value = Format(wsCalc.Range("CCBalance1"), "Currency")
End With
End If
Next
This is untested, but give it a try. It assumes the relationship between range name and textbox is as straightforward as it appears.
Sub x()
Dim i As Long
For i = 1 To 9
If Range("CCBalance" & i).Value > 0 Then 'I believe this will choose the first cell in the range named above
With RiskCalc.Controls("CCBal" & i)
.Visible = True
.Value = Format(Range("CCBalance" & i), "Currency")
End With
End If
Next i
End Sub
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 am trying to create a For and Do while loop in VBA. I want that when the value 'X' is entered in column A and if column W is equal to "T", all the rows below (column A) should be checked "X" until the next value "T" in column W.
My script does not work, only the row below is filled with "X" and the file closes (bug!)
Here is the complete code
Sub Chaine()
For Each Cell In Range("A2:A3558")
If UCase(Cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While Cell.Offset(0, 23) <> "T"
Cell.Offset(1, 0).Value = "X"
Loop
End If
Next Cell
End Sub
Try this:
Sub Chaine()
Dim c As Range, vW, flag As Boolean
For Each c In ActiveSheet.Range("A2:A3558").Cells
vW = UCase(c.EntireRow.Columns("W").value)
If UCase(c.value) = "X" And vW = "T" Then
flag = True 'insert "X" beginning on next row...
Else
If vW = "T" Then flag = False 'stop adding "X"
If flag Then c.value = "X"
End If
Next c
End Sub
Your Do While loop has to be problem as it doesn't change and will continue to check the same thing. It's unclear what you want to happen, but consider something like this as it moves to the right until you've exceeded the usedrange.
Sub Chaine()
Dim cell As Range
For Each cell In Range("A2:A3558").Cells
If UCase(cell.Value) = "X" And Cells(Target.Row, 23) = "T" Then
Do While cell.Offset(0, 23) <> "T"
Set cell = cell.Offset(0, 1)
'not sure what this is supposed to do...?
'cell.Offset(1, 0).Value = "X"
If cell.Column > cell.Worksheet.UsedRange.Cells(1, cell.Worksheet.UsedRange.Columns.Count).Column Then
MsgBox "This has gone too far left..."
Stop
End If
Loop
End If
Next cell
End Sub
I just went off your description in the question. Your code is not doing what you want and it's not really how you would do this in my opinion. I figured I would put an answer that does what you ask but, keep it simple.
I'm guessing Target in the code refers to an event.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo SomethingBadHappened
'Checks if you are in the A column from the target cell that
'was changed and checks if only X was typed.
If (Target.Column = 1 And UCase(Target) = "X") Then
Dim colToCheck_Index As Integer
colToCheck_Index = 23 'W Column
Dim colToCheck_Value As String
Dim curRow_Index As Integer
curRow_Index = Target.Cells.Row
'Checks if the column we are checking has only a T as the value.
If (UCase(ActiveSheet.Cells(curRow_Index, colToCheck_Index).Value) = "T") Then
Application.EnableEvents = False
Do
'Set the proper cell to X
Range("A" & curRow_Index).Value = "X"
curRow_Index = curRow_Index + 1
'Set the checking value to the next row and check it in the
'while loop if it doesn't equal only T
colToCheck_Value = ActiveSheet.Cells(curRow_Index, colToCheck_Index)
'Set the last row to X on the A column.
Loop While UCase(colToCheck_Value) <> "T"
Range("A" & curRow_Index).Value = "X"
Application.EnableEvents = True
End If
Exit Sub
SomethingBadHappened:
Application.EnableEvents = True
End If
End Sub
I am adding the contents of cells to a shape object. The contents are all text, but each cell may have different formatting. I would like to be able to preserve this formatting when adding the content of the cells to the shape, so that a bold cell will appear as such and so on.
I have been trying to take the current Shape.TextFrame.Characters object and add the new Range("TargetCell").Characters object to it, for each target cell in my source range.
Is there a simple way to force two .Characters objects together, so the text concatenates and the formatting changes to reflect the source at the boundary of the new text - I see the .Characters.Insert(string) method, but that only inserts the text, not the formatting. Every time I add a new cell to the output list, I need to recalculate where each portion of text has what formatting, which is proving to be difficult.
I was trying along these lines, but keep coming into difficulties trying to get or set the .Characters(n).Font.Bold property.
Private Sub buildMainText(Target As Range, oSh As Shape)
On Error GoTo 0
Dim chrExistingText As Characters
Dim chrTextToAdd As Characters
Dim chrNewText As Characters
Dim o As Characters
Dim i As Integer
Dim isBold As Boolean
Dim startOfNew As Integer
i = 0
With oSh.TextFrame
Set chrExistingText = .Characters
Set chrTextToAdd = Target.Characters
Set chrNewText = chrTextToAdd
chrNewText.Text = chrExistingText.Text & chrTextToAdd.Text
startOfNew = Len(chrExistingText.Text) + 1
.Characters.Text = chrNewText.Text
For i = 1 To Len(chrNewText.Text)
If i < startOfNew Then
If chrExistingText(i, 1).Font.Bold Then
.Characters(i, 1).Font.Bold = True
Else
.Characters(i, 1).Font.Bold = False
End If
Else
If chrNewText(i - startOfNew + 1, 1).Font.Bold Then
.Characters(i, 1).Font.Bold = True
Else
.Characters(i, 1).Font.Bold = False
End If
End If
Next i
End With
End Sub
Here is an example which takes a single cell and appends it to a shape; preserving, shape's and range's formattings. In the example below, we will preserve BOLD (B), ITALICS (I) and UNDERLINE (U). Feel free to modify the code to store more formatting attributes.
LOGIC:
The maximum length of characters you can have in a shape's textframe is 32767. So we will create an array (as #SJR mentioned in the comments above) say, TextAr(1 To 32767, 1 To 3), to store the formatting options. The 3 columns are for B,U and I. If you want to add more attributes then change it to the relevant number.
Store the shape's formatting in an array.
Store the cells's formatting in an array.
Append the cell's text to the shape.
Loop through the array and re-apply the formatting.
CODE:
I have commented the code but if you have a problem understanding it then simply ask. I quickly wrote this so I must confess that I have not done extensive testing of this code. I am assuming that the cell/shape doesn't have any other formatting other than B, I and U(msoUnderlineSingleLine). If it does, then you will have to amend the code accordingly.
Option Explicit
Sub Sample()
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = Sheet1
AddTextToShape ws.Range("F3"), ws.Shapes("MyShape")
End Sub
'~~> Proc to add cell range to shape
Sub AddTextToShape(rng As Range, shp As Shape)
'~~> Check for single cell
If rng.Cells.Count > 1 Then
MsgBox "Select a single cell and try again"
Exit Sub
End If
Dim rngTextLength As Long
Dim shpTextLength As Long
'~~> Get the length of the text in the supplied range
rngTextLength = Len(rng.Value)
'~~> Get the length of the text in the supplied shape
shpTextLength = Len(shp.TextFrame.Characters.Text)
'~~> Check if the shape can hold the extra text
If rngTextLength + shpTextLength > 32767 Then
MsgBox "Cell text will not fit in Shape. Choose another cell with maximum " & _
(32767 - shpTextLength) & " characters"
Exit Sub
End If
Dim TextAr(1 To 32767, 1 To 3) As String
Dim i As Long
'~~> Store the value and formatting from the shape in the array
For i = 1 To shpTextLength
With shp.TextFrame.Characters(i, 1)
With .Font
If .Bold = True Then TextAr(i, 1) = "T" Else TextAr(i, 1) = "F"
If .Italic = True Then TextAr(i, 2) = "T" Else TextAr(i, 2) = "F"
If .Underline = xlUnderlineStyleSingle Then TextAr(i, 3) = "T" Else TextAr(i, 3) = "F"
End With
End With
Next i
'~~> Store the value and formatting from the range in the array
Dim j As Long: j = shpTextLength + 2
For i = 1 To rngTextLength
With rng.Characters(Start:=i, Length:=1)
With .Font
If .Bold = True Then TextAr(j, 1) = "T" Else TextAr(j, 1) = "F"
If .Italic = True Then TextAr(j, 2) = "T" Else TextAr(j, 2) = "F"
If .Underline = xlUnderlineStyleSingle Then TextAr(j, 3) = "T" Else TextAr(j, 3) = "F"
j = j + 1
End With
End With
Next i
'~~> Add the cell text to shape
shp.TextFrame.Characters.Text = shp.TextFrame.Characters.Text & " " & rng.Value2
'~~> Get the new text length of the shape
shpTextLength = Len(shp.TextFrame.Characters.Text)
'~~> Apply the formatting
With shp
For i = 1 To shpTextLength
With .TextFrame2.TextRange.Characters(i, 1).Font
If TextAr(i, 1) = "T" Then .Bold = msoTrue Else .Bold = msoFalse
If TextAr(i, 2) = "T" Then .Italic = msoTrue Else .Italic = msoFalse
If TextAr(i, 3) = "T" Then .UnderlineStyle = msoUnderlineSingleLine _
Else .UnderlineStyle = msoNoUnderline
End With
Next i
End With
End Sub
IN ACTION
Good afternoon to all.
I now need be able to send the formatted textbox back to the originating active cell.
This code was copy format from cell to textbox, I now need to reverse this process
Sub passCharToTextbox()
CopycellFormat ActiveCell
End Sub
Private Sub CopycellFormat(cell As Range)
If Trim(cell(1, 1).Value) = vbNullString Then MsgBox ("select only cell / not emptycell"): Exit Sub
Dim textrange As TextRange2, tbox1 As Shape, fontType As Font2
With ActiveSheet
On Error Resume Next: Err.Clear 'check if Textbox 2 exist
Set tbox1 = .Shapes("Textbox 2"): Set textrange = tbox1.TextFrame2.textrange
textrange.Characters.Text = cell.Value
If Err.Number > 0 Then MsgBox ("Not found Textbox 2")
For i = 1 To Len(cell.Value)
Set fontType = textrange.Characters(i, 1).Font
With cell.Characters(i, 1)
fontType.Bold = IIf(.Font.Bold, True, 0) 'add bold/
fontType.Italic = IIf(.Font.Italic, True, 0) 'add italic/
fontType.UnderlineStyle = IIf(.Font.Underline > 0, msoUnderlineSingleLine, msoNoUnderline) 'add underline/
textrange.Characters(i, 1).Font.Fill.ForeColor.RGB = .Font.Color 'add Font color
End With
Next i
tbox1.Fill.ForeColor.RGB = cell.Interior.Color 'add background color
End With
End Sub
Many thanks for taking the time to read, and please everyone, stay well.
focus on your problem:
First, make sure "textbox 2" exists
Then, Select the cell need to copy format and run the code CopyFormat_fromTextbox_toCell
Here's following code:
Sub CopyFormat_fromTextbox_toCell()
CopycellFormat1 activecell
End Sub
Private Sub CopycellFormat1(cell As Range)
Dim textrange As TextRange2, tbox1 As Shape, fontType As Font2, cellfont As Font
With ActiveSheet
Set tbox1 = .Shapes("Textbox 2"): Set textrange = tbox1.TextFrame2.textrange
cell.Value = textrange.Characters.Text
For i = 1 To Len(cell.Value)
Set fontType = textrange.Characters(i, 1).Font
Set cellfont = cell.Characters(i, 1).Font
With fontType
cellfont.Bold = IIf(.Bold, True, 0) 'add bold/
cellfont.Italic = IIf(.Italic, True, 0) 'add italic/
cellfont.Underline = IIf(.UnderlineStyle > 0, 2, -4142) 'add underline/
cellfont.Color = textrange.Characters(i, 1).Font.Fill.ForeColor.RGB 'add Font color
End With
Next i
cell.Interior.Color = tbox1.Fill.ForeColor.RGB 'add background color
End With
End Sub
I would like to insert the check box in particular cell through macro.
For example: On click of a command button i should be able to add the check box to A1 cell.
Sheets("Pipeline Products").Range("O" & i & ":AG" & i).Select
ActiveSheet.CheckBoxes.Add(4, 14.5, 72, 17.25).Select
With Selection
.Caption = ""
.Value = xlOff '
.LinkedCell = "C" & ToRow
.Display3DShading = False
End With
This simple line allows you to add CheckBox to cell A1 and set width and height accordingly:
ActiveSheet.OLEObjects.Add "Forms.CheckBox.1", Left:=Range("A1").Left, Top:=Range("A1").Top, Width:=Range("A1").Width, Height:=Range("A1").Height
You can easily add it to CommandButton this way:
Private Sub CommandButton1_Click()
ActiveSheet.OLEObjects.Add "Forms.CheckBox.1", Left:=Range("A1").Left, Top:=Range("A1").Top, Width:=Range("A1").Width, Height:=Range("A1").Height
End Sub
Edit Your code improved...
You simply need to add loop to insert checkboxes into several cells:
Sub YourCode_Improvment()
Dim i
'
For i = 1 To 10 'cells from 1st to 10th
ActiveSheet.CheckBoxes.Add(Cells(i, "A").Left, _
Cells(i, "A").Top, _
72, 17.25).Select
With Selection
.Caption = ""
.Value = xlOff '
.LinkedCell = "C" & i
.Display3DShading = False
End With
Next
End Sub
Change this code accordingly, if needed.
Slightly upgraded code in the top comment. Simply select a range and run it, it'll fill all selected cells with checkboxes:
Sub InsertCheckboxes()
Dim c As Range
For Each c In Selection
Dim cb As CheckBox
Set cb = ActiveSheet.CheckBoxes.Add(c.Left, _
c.Top, _
c.Width, _
c.Height)
With cb
.Caption = ""
.Value = xlOff
.LinkedCell = c.Address
.Display3DShading = False
End With
Next
End Sub
You can use a For Each loop to add the check boxes.
Dim i as Integer
Dim cel As Range
i = 10
For Each cel In Sheets("Pipeline Products").Range("O" & i & ":AG" & i)
ActiveSheet.OLEObjects.Add "Forms.CheckBox.1", Left:=cel.Left, Top:=cel.Top, Width:=cel.Width, Height:=cel.Height
Next
Hope this helps.