"Object required" error VBA - excel

I've got a Worksheet titled "Survey". I'm trying to attach checkboxes to all of the cells in column A that are next to answers, and for some reason I'm getting an "object required" error. The 4 lines near the beginning, starting with "Set rng =", are highlighted.
I'm pretty new to VBA, so I'm not sure if this is just a simple syntax issue that I'm not seeing. I've tried searching for the proper format, to no avail. Can anyone help? Here's the code that I've got:
Sub AddCheckBox()
Dim rng As Range
Dim rcell As Range
Set rng = Survey.Range("A7:A10,A13:A17,A21:A25,A28:A33" _
& "A36:A43, A48,A51:A56,A60:A66,A69:A73,A76:A80" _
& "A83:A87, A90:A94, A97:A102, A105:A113, A116:A122, A125:A131" _
& "A134:A141,A145:A149, A152:A158, A161:A165")
DelCheckBox
For Each rcell In rng
With ActiveSheet.CheckBoxes.Add(rcell.Left, _
rcell.Top, rcell.Width, rcell.Height)
.LinkedCell = rcell.Offset(, 0).Address(External:=True)
.Interior.ColorIndex = 14 'or xlNone or xlAutomatic
.Caption = ""
.Border.Weight = xlThin
End With
Next
With Range("A7:A10,A13:A17,A21:A25,A28:A33" _
& "A36:A43, A48,A51:A56,A60:A66,A69:A73,A76:A80" _
& "A83:A87, A90:A94, A97:A102, A105:A113, A116:A122, A125:A131" _
& "A134:A141,A145:A149, A152:A158, A161:A165")
.Rows.RowHeight = 15
End With
End Sub
Sub DelCheckBox()
For Each cell In Range("A1:A166")
Worksheets("Survey").CheckBoxes.Delete
Next
End Sub

You're missing the commas at the end of your lines. Try this:
Set rng = Survey.Range("A7:A10,A13:A17,A21:A25,A28:A33," _
& "A36:A43, A48,A51:A56,A60:A66,A69:A73,A76:A80," _
& "A83:A87, A90:A94, A97:A102, A105:A113, A116:A122, A125:A131," _
& "A134:A141,A145:A149, A152:A158, A161:A165")
Note, you'll have to make the same change where you have the With Range("....") block as well. Also, the above code does not reflect the validity of the rest of what you're trying to do...just that one error.
EDIT to fix issues down the road...
Try this all of this code and see if it does what you're after:
Sub test()
Dim rng As Range
Dim rcell As Range
Set rng = Sheets("Survey").Range("A7:A10,A13:A17,A21:A25,A28:A33," _
& "A36:A43, A48,A51:A56,A60:A66,A69:A73,A76:A80," _
& "A83:A87, A90:A94, A97:A102, A105:A113, A116:A122, A125:A131," _
& "A134:A141,A145:A149, A152:A158, A161:A165")
DelCheckBox
For Each rcell In rng
With Sheets("Survey").CheckBoxes.Add(rcell.Left, _
rcell.Top, rcell.Width, rcell.Height)
.LinkedCell = rcell.Offset(, 0).Address(External:=True)
.Interior.ColorIndex = 14 'or xlNone or xlAutomatic
.Caption = ""
.Border.Weight = xlThin
End With
Next
rng.Rows.RowHeight = 15
End Sub
Sub DelCheckBox()
Sheets("Survey").DrawingObjects.Delete
End Sub

Related

Return result on conditional format

Im working on a excel script, that will import a CSV file, analyse the result and create a report based on the analyse.
The CSV file contain up to 12 measurement. and all have to be vertified before the mesurement can be confirmed and end up on the report.
I would like to use conditional format to analyze the result. And need to know if the conditional is OK or not OK.
So my question is: Is there a way to change a boolean, if the conditional goes from FALSE to TRUE using the FormatConditions(1).StopIfTrue = True
Here is a snip of the code.
'Add first rule
RangeLength.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
Formula1:=LengthMin, Formula2:=LengthMax
RangeLength.FormatConditions(1).Interior.Color = RGB(255, 0, 0)
RangeLength.FormatConditions(1).StopIfTrue = True
If FormatConditions(1) = True Then
Range("D" & lastRow).Value = True
End If
Edit:
Here are the full sub snip:
Sub MultipleConditionalFormattingExample()
Dim RangeLength As Range
Dim sht As Worksheet
Dim lastRow As Long
Dim LengthMax As Variant, LengthMin As Variant
Set sht = Worksheets("Collection")
lastRow = sht.ListObjects("collectionData").Range.Rows.Count
LengthMax = Worksheets("Engine").Range("G3").Value
LengthMin = Worksheets("Engine").Range("G4").Value
'Create range object
Set RangeLength = Range("G2:G" & lastRow)
RangeLength.Select
'Delete previous conditional formats
RangeLength.FormatConditions.Delete
'Add first rule
RangeLength.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
Formula1:=LengthMin, Formula2:=LengthMax
RangeLength.FormatConditions(1).Interior.Color = RGB(255, 0, 0)
'Add second rule
RangeLength.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
Formula1:=LengthMin
RangeLength.FormatConditions(2).Interior.Color = vbBlue
'Add third rule
RangeLength.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
Formula1:=LengthMax
RangeLength.FormatConditions(3).Interior.Color = vbYellow
RangeLength.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
Formula1:=LengthMax
Debug.Print ActiveSheet.Range("G4").Interior.Color & " should be blue"
Debug.Print ActiveSheet.Range("G5").Interior.Color & " should be red"
Debug.Print ActiveSheet.Range("G8").Interior.Color & " should be yellow"
End Sub
And here are the result of the immediate window:
16777215 should be blue
16777215 should be red
16777215 should be yellow
Hope someone can understand by problem and point me in the right direction.
Thanks
dk.ties

How can I increase the speed of this FOR NEXT loop

I wrote this code over the weekend and it was blazing fast, when I got to work on Monday I sent an email before testing the code while servers had a load and it is infinitely slower. We are talking from 30 seconds to 15 minutes.
For x = 3 To SRLastRow
If Left(shMacro.Range("D" & x), 3) = "625" Then
shMacro.Range("BW" & x) = WorksheetFunction.XLookup(Arg1:=shMacro.Range("A" & x), Arg2:=WIPFile.Worksheets("Customer Master").Range("B:B"), Arg3:=WIPFile.Worksheets("Customer Master").Range("AD:AD"))
Else
shMacro.Range("BW" & x) = WorksheetFunction.XLookup(Arg1:=shMacro.Range("A" & x), Arg2:=WIPFile.Worksheets("Customer Master").Range("B:B"), Arg3:=WIPFile.Worksheets("Customer Master").Range("AH:AH"))
End If
If shMacro.Range("BW" & x) <> shMacro.Range("BX" & x) Then
shMacro.Range("BX" & x).Interior.ColorIndex = 3
ErrorCount = ErrorCount + 1
End If
Next x
I essentially need to pull in a value, then compare that pulled in value with a value on my Macro worksheet. If the values match do nothing, otherwise color the cell red.
I came up with the following, but haven't tested it fully yet, but the problem remains having to cycle through to find mismatches to color them.
shMacro.Range("BW3").Formula = "=IF(LEFT(D3,3)=""625"",XLOOKUP(TEXT(A3,""000""),'[WORKBOOK]Customer Master'!$AD:$AD),XLOOKUP(TEXT(A3,""000""),'[WORKBOOK]Customer Master'!$B:$B,'[WORKBOOK]Customer Master'!$AH:$AH))"
Range("BW3").AutoFill Destination:=Range("BW3:BW" & SRLastRow)
I've also tried looking into Arrays but I can't seem to figure those out. I think the autofill would be the fastest way to pull in the data, then somehow assign the two arrays (which would be columns BW and BX) and if they match do nothing, wherever they are different color BX + row reference red, and count the number of times it colored something red.
Should be a little faster (reducing cell reads without going "full array mode" and coloring all mismatches in one shot)
Sub Tester()
Dim x As Long, SRLastRow As Long
Dim colReturn As String, v, rngRed As Range, rw As Range
'...
'...
'...
Application.ScreenUpdating = False
For x = 3 To SRLastRow
Set rw = shMacro.Rows(x)
colReturn = IIf(Left(rw.Columns("D").Value, 3) = "625", "AD:AD", "AH:AH")
v = Application.XLookup( _
Arg1:=rw.Columns("A").Value, _
Arg2:=WIPFile.Worksheets("Customer Master").Range("B:B"), _
Arg3:=WIPFile.Worksheets("Customer Master").Range(colReturn))
If Not IsError(v) Then
rw.Columns("BW").Value = v
With rw.Columns("BX")
If v <> .Value Then
BuildRange rngRed, .Cells(1)
ErrorCount = ErrorCount + 1
End If
End With
End If
Next x
'color the mismatches if any
If Not rngRed Is Nothing Then rngRed.Interior.ColorIndex = 3
End Sub
'utility - build a range using Union
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
I think the reason for the slow processing is in the location of the WIPFile workbook. Therefore my code below minimizes the need to access it. I couldn't test my code for lack of data but I hope you will try it.
Sub Snippet()
' 214
Dim LookUpRng As Range ' in "Customer Master"
Dim ReturnVals As Variant ' values from "Customer Master"
Dim C As Long ' Lookup column in ReturnRng
Dim Fnd As Range ' search result
Dim x As Long ' loop counter: rows (why "x" and not "R" ?)
Dim ErrorCount As Variant
Dim Spike As String ' collect failed lookups
ErrorCount = 0
With WIPFile.Worksheets("Customer Master")
Set LookUpRng = .Columns("BB")
ReturnVals = .Range(.Columns("AD"), .Columns("AH")).Value
End With
With shMacro
For x = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
Set Fnd = LookUpRng.Find(.Cells(x, "A").Value, LookIn:=xlValues, LookAt:=xlWhole)
If Fnd Is Nothing Then
If Len(Spike) Then Spike = Spike & vbCr
Spike = Spike & String(6, " ") & """" & .Cells(x, 1).Value & """ in row " & x
Else
C = IIf(Left(.Cells(x, "D").Value, 3) = "625", 1, 5)
With .Cells(x, "BW")
.Value = ReturnVals(Fnd.Row, C)
If .Value <> .Cells(x, "BX").Value Then
.Interior.ColorIndex = 3
ErrorCount = ErrorCount + 1
End If
End With
End If
Next x
End With
If Len(Spike) Then
Spike = "The following look-ups were not successful." & vbCr & _
Spike & IIf(ErrorCount, vbCr, "")
Else
Spike = "All look-ups were successful."
End If
If ErrorCount = 0 Then ErrorCount = "No"
Spike = Spike & vbCr & ErrorCount & " matching error" & _
IIf(ErrorCount = 1, "", "s") & " were highlighted."
MsgBox Spike, vbInformation, "Action report"
End Sub
If my approach shows promise more speed could be gained by reading column B:B into another array and use a MATCH function instead of Find. In that way "Customer Master" would need to be accessed only once. Of course, you could also gain a little time by suspending ScreenUpdating during execution.
No VBA required. Use Formula + Conditional formatting
Entering the formula
Put this formula in BW3 and copy it down. Change SAMPLE.xlsx to the relevant file.
=IF(LEFT(D3,3)=625,XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AD:$AD),XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AH:$AH))
Setting up Conditional Formatting
Select the relevant range, starting for row 3.
Click on Home | Conditional formatting | New Rule | Use formula to determine which cells to format
Enter the formula =BW3<>BX3 and set the relevant color.
And you are done.
If you still want VBA then also you do not need any kind of loop or Autofill. You can enter the formula via VBA in all the cells in 1 GO! Here is an example (UNTESTED)
With shMacro
lrow = .Range("D" & .Rows.Count).End(xlUp).Row
.Range("BW3:BW" & lrow).Formula = "=IF(LEFT(D3,3)=625,XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AD:$AD),XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AH:$AH))"
End With
For conditional formatting you can use this code
With shMacro.Range("BW3:BW" & lrow)
.FormatConditions.Add Type:=xlExpression, Formula1:="=BW3<>BX3"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
So basically your entire code can be written as
With shMacro
lrow = .Range("D" & .Rows.Count).End(xlUp).Row
With .Range("BW3:BW" & lrow)
.Formula = "=IF(LEFT(D3,3)=625,XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AD:$AD),XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AH:$AH))"
DoEvents
.FormatConditions.Add Type:=xlExpression, Formula1:="=BW3<>BX3"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
End With

Code execution has been interrupted

In Excel VBA, I am running into an "error" that halts the macro and a message displays "Code execution has been interrupted." I wrote error in quotations because when I selected debug and examined the line of code that prompted the error, I saw that it was logically sound.
I originally ran into the error at On Error GoTo 0. When I comment out a block around the error, then I get a new line that produces the same error. And, again, when I examine it in debug mode the new "error" is logically sound. Here is the exact line:
If rRange.Row <> 3 And rRange.Row <> 17 Then
FYI, rRange.Row = 3 in this case, so it shouldn't produce an error.
Why is this happening and how can I fix it?
UPDATE Code now produces the error on the End Sub line.
Here is the section that fails:
Sub Review()
Dim WorkRange As Range
Dim FoundCells As Range
Dim Cell As Range
Dim a As String
Dim policy As String
Dim rRange As Range
Set RR = Sheets("Ready for Review")
Set OG = ActiveSheet
OG.Unprotect ("Password")
RR.Activate
On Error Resume Next
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:= _
"Please select POLICY to review.", _
Title:="SPECIFY POLICY", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rRange.Row <> 3 And rRange.Row <> 17 Then
MsgBox "Value other than a POLICY was selected. Select the cell that contains the correct policy number."
Exit Sub
Else
policy = rRange.Value
End If
Application.ScreenUpdating = False
OG.Cells(12, 2).Locked = False
Set WorkRange = OG.UsedRange
For Each Cell In WorkRange
If Cell.Locked = False Then
col1 = Cell.Column
Row = Cell.Row
a = OG.Cells(Row, 1)
If Not a = "" Then
row2 = Application.WorksheetFunction.Match(a, RR.Range("A:A"), 0)
Cell.Value = RR.Cells(row2, rRange.Column + col1 - 2)
End If
End If
Next Cell
OG.Unprotect ("Password")
OG.Cells(33, 3).Locked = False
If (Right(OG.Cells(5, 2), 2) = "UL" Or Right(OG.Cells(5, 2), 2) = "IL" Or Right(OG.Cells(5, 2), 2) = "PL") Then
With OG.Cells(33, 3)
.Value = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""Total*"",A:A,0)))-SUM(C34:C37)"
.Locked = True
End With
ElseIf Right(OG.Cells(5, 2), 2) = "WL" Then
With OG.Cells(33, 3)
.Value = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""*"",A:A,0))) - IFERROR(INDEX(C34:C37,MATCH(""Additional"",B34:B37, 0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Paid"",B34:B37,0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Additional Agreement - SPPUA"",B34:B37, 0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Flexible Agreement - FLXT10/20"",B34:B37, 0)),0)"
.Locked = True
End With
Else
With OG.Cells(33, 3)
.Value = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""*"",A:A,0)))"
.Locked = True
End With
End If
OG.Activate
Cells(Application.WorksheetFunction.Match("Last Month Paid ($)", Range("A:A"), 0), 2).NumberFormat = "$#,##0.00;[Red]$#,##0.00"
OG.Protect ("Password")
Application.ScreenUpdating = True
End Sub
Oh, that brings back memories for me. I think I used to get this error about 10 years ago Excel 2003? Maybe?. Excel would get itself into a bit of a state. Nothing was wrong with the code, just it would keep coming back with that error.
If you save your work close Excel and then reopen, does the error go away?
If I remember right, it was caused when I called some external API. Maybe some other API call in your is causing this error but manifesting at this point... perhaps.
Sorry but it was 10+ years ago :)
even if you went through it, you may want to consider the following "restyling" of the code you posted
Option Explicit
Sub Review()
Dim Cell As Range, rRange As Range
Dim a As String
Dim RR As Worksheet, OG As Worksheet
Set RR = Sheets("Ready for Review")
Set OG = ActiveSheet
OG.Unprotect ("Password")
Set rRange = GetUserInpt(RR)
If rRange Is Nothing Then
MsgBox "You aborted the POLICY selection" _
& vbCrLf & vbCrLf _
& "the procedure ends" _
, vbInformation
Exit Sub
End If
Application.ScreenUpdating = False
OG.Cells(12, 2).Locked = False
For Each Cell In OG.UsedRange
With Cell
If Not .Locked Then
a = OG.Cells(.row, 1)
If Not a = "" Then .value = RR.Cells(CLng(Application.WorksheetFunction.Match(a, RR.Range("A:A"), 0)), _
rRange.Column + .Column - 2)
End If
End With
Next Cell
With OG.Cells(33, 3)
.Locked = False
Select Case Right(OG.Cells(5, 2), 2)
Case "UL", "IL", "PL"
.Formula = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""Total*"",A:A,0)))-SUM(C34:C37)"
Case "WL"
.Formula = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""*"",A:A,0))) - IFERROR(INDEX(C34:C37,MATCH(""Additional"",B34:B37, 0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Paid"",B34:B37,0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Additional Agreement - SPPUA"",B34:B37, 0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Flexible Agreement - FLXT10/20"",B34:B37, 0)),0)"
Case Else
.value = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""*"",A:A,0)))"
End Select
.Locked = True
End With
OG.Activate
Cells(Application.WorksheetFunction.Match("Last Month Paid ($)", Range("A:A"), 0), 2).NumberFormat = "$#,##0.00;[Red]$#,##0.00"
OG.Protect ("Password")
Application.ScreenUpdating = True
End Sub
Function GetUserInpt(sht As Worksheet) As Range
Dim rRange As Range
Application.DisplayAlerts = False
sht.Activate
On Error GoTo InputBoxCanceled
Do While rRange Is Nothing
Set rRange = Application.InputBox(Prompt:="Please select POLICY to review.", _
Title:="SPECIFY POLICY", _
Default:=sht.Cells(3, 1).Address, _
Type:=8)
If rRange.Parent.Name <> sht.Name Then
MsgBox "You must select a cell in '" & sht.Name & "' sheet"
sht.Activate
Set rRange = Nothing
Else
If rRange.row <> 3 And rRange.row <> 17 Then
MsgBox "Value other than a POLICY was selected" _
& vbCrLf & vbCrLf _
& "Select the cell that contains the correct policy number" _
, vbCritical
Set rRange = Nothing
End If
End If
Loop
Set GetUserInpt = rRange
InputBoxCanceled:
On Error GoTo 0
Application.DisplayAlerts = True
End Function
the main revision applies to:
added a GetUserInpt function to handle the policy selection
this function:
checks for both the correct selection row and sheet, too (since it's possible the user shifts to another worksheet during selection!)
runs a loop until the user selects a proper cell
exits selection upon user canceling the InputBox, as the only loop escape possibility
made some simplifications here and there, like:
eliminated Activate statements unless really needed
reduced the amount of variables to only (nearly) strictly needed ones
added some With ... End With blocks to add readability
used a Select Case block instead of an If ... Then ... Else if ... Else ... End if one, for readability again
changed .Value to .Formula, for a proper syntax
all what above could help you with this project and in future ones, too

How can I create a macro that would add a prefix and suffix to a formula in a range?

I wish to create a macro that requests a "prefix" and "suffix" from the user, as well as a range. The prefix will be placed in front of each formula, while the suffix will be placed at the end of each formula across the entire range. For example, if A1 contains ABC with a prefix =LEFT( and a suffix ,1), the formula in A1 should change from ABC to =LEFT(ABC,1) and therefore only display A.
The best way to provide a user interface for this is via a form. Let's call it a "macro wrapper":
This is what it should look like in action:
Here is my VBA code for cmdApply and cmdCancel buttons:
Private Sub cmdApply_Click()
Dim DataValue As Range
For Each DataValue In Range(redtSelectRange)
If Left(DataValue.Formula, 1) = "=" Then
DataValue.Formula = "=" & _
Trim(txtBefore.Text) & _
Right(DataValue.Formula, Len(DataValue.Formula) - 1) & _
Trim(txtAfter.Text)
Else
DataValue.Formula = "=" & _
Trim(txtBefore.Text) & _
DataValue.Formula & _
Trim(txtAfter.Text)
End If
Next DataValue
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
However, when I compile the above I receive a "Run-time error '1004': Application-defined or object-defined error".
I tried shortening the cmdApply condition to an Immediate If statement:
Private Sub cmdApply_Click()
Dim DataValue As Range
For Each DataValue In Range(redtSelectRange)
DataValue.Formula = "=" & _
Trim(txtBefore.Text) & _
IIf(Left(DataValue.Formula, 1) = "=", Right(DataValue.Formula, Len(DataValue.Formula) - 1), DataValue.Formula) & _
Trim(txtAfter.Text)
End If
Next DataValue
End Sub
and even the Intermediate window shows the correct (expected) output for the first entry in the range:
?Trim(txtBefore.Text) & IIf(Left(DataValue.Formula, 1) = "=", Right(DataValue.Formula, Len(DataValue.Formula) - 1), DataValue.Formula) & trim(txtAfter.Text)
=round(1.2,0)
What should I change in my code to properly add/insert the prefix/suffix for each of the range's formulae?
Based on your code and your sample from the image, your .Formula assignment will end up being:
==round(1.2,0)
To fix it:
Private Sub cmdApply_Click()
Dim DataValue As Range
For Each DataValue In Range(redtSelectRange)
If Left(txtBefore.Text, 1) = "=" Then
DataValue.Formula = Trim(txtBefore.Text) & _
Right(DataValue.Formula, Len(DataValue.Formula) - 1) & _
Trim(txtAfter.Text)
Else
DataValue.Formula = "=" & _
Trim(txtBefore.Text) & _
DataValue.Formula & _
Trim(txtAfter.Text)
End If
Next DataValue
End Sub
Try this:
Private Sub cmdApply_Click()
Dim DataValue As Range
For Each DataValue In Range(redtSelectRange)
'Your code had an additional "=" leading into this string below but in your
'example, there was already a leading "=" in the txtBefore.Text. If you
'don't know if it will always have a leading "=" then add some code to
'make sure only 1 is included
If Left(DataValue.Formula, 1) = "=" Then
DataValue.Formula = Trim(txtBefore.Text) & _
Right(DataValue.Formula, Len(DataValue.Formula) - 1) & _
Trim(txtAfter.Text)
Else
DataValue.Formula = "=" & _
Trim(txtBefore.Text) & _
DataValue.Formula & _
Trim(txtAfter.Text)
End If
Next 'DataValue isn't required here
End Sub
Sub AddText_Prefix_And_Suffix()
Dim rng As Range
Dim Workrng As Range
Dim Prefix As String
Dim Suffix As String
On Error Resume Next
xTitleId = "Range Selector"
Set Workrng = Application.Selection
Set Workrng = Application.InputBox("Range", xTitleId, Workrng.Address, Type:=8)
Prefix = Application.InputBox("Enter Prefix", xTitleId, "Prefix", Type:=2)
Suffix = Application.InputBox("Enter Suffix", xTitleId, "Suffix", Type:=2)
If Prefix = "False" And Suffix = "False" Then
MsgBox "User cancelled"
Else
For Each rng In Workrng
rng.Value = Prefix & rng.Value
rng.Value = rng.Value & Suffix
Application.ScreenUpdating = False
Next
End If
MsgBox "Done"
End Sub
You can use this a simplified version with same result as you are expecting.
this code will ask user to select range to operate, after that it will prompt again for suffix and prefix, using that the existing data will be altered only to selected range
Hope it helps someone

insert check box to a particular cell through vba macro

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.

Resources