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.
Related
I have created a UserForm with some textboxes and comboboxes inside, the data that is typed in textboxes are supposed to be inserted in cell in the sheet, the determation of which cell is based on the value in ComboBox4. unfortunately the code keeps giving me error: "Run-time error '13': Type mismatch" and I have not been able to find out what is going wrong?
if someone knows what the problem is please let me know.
Private Sub UserForm_Initialize()
ComboBox3.List = [ADMIN!e2:E1000].Value
ComboBox4.List = [PRODUCTION!O6:O1000].Value
End Sub
Private Sub ACCEPTBUTTON_Click()
Application.ScreenUpdating = False
Worksheets("PRODUCTION").Activate
Dim C As Long
For C = 1000 To 1 Step -1
If Cells(C + 1, 1) Like ComboBox4 Then
Cells(C + 1, 1).EntireRow.Select
Selection.EntireRow.Hidden = False
Application.CutCopyMode = False
End If
Next C
Range("AC" & (ActiveCell.Row)).Value = TextBox1.Value
Range("AD" & (ActiveCell.Row)).Value = TextBox2.Value
Range("AE" & (ActiveCell.Row)).Value = TextBox3.Value
Range("AF" & (ActiveCell.Row)).Value = TextBox4.Value
Range("AG" & (ActiveCell.Row)).Value = TextBox5.Value
Range("AH" & (ActiveCell.Row)).Value = TextBox6.Value
Range("AI" & (ActiveCell.Row)).Value = TextBox7.Value
Range("AJ" & (ActiveCell.Row)).Value = TextBox8.Value
ActiveCell.EntireRow.RowHeight = 16
Unload Me
Application.ScreenUpdating = True
End Sub
Here's some commented code that should work for you. I did find it strange that you populate the values in ComboBox4 from column O, but then search column A for matches, is that intentional? (In the provided code, it searches for matches from the same list as populated the combobox which will guarantee a match is found).
Also, instead of a 1000 long loop to find the matches, this uses a Range.Find loop to increase speed and efficiency.
'Declare userform variables that any of this userform's Subs can reference
Private wb As Workbook
Private wsAdm As Worksheet
Private wsPrd As Worksheet
Private rAdmList As Range
Private rPrdList As Range
Private Sub UserForm_Initialize()
'Populate userform variables
Set wb = ThisWorkbook
Set wsAdm = wb.Worksheets("ADMIN")
Set wsPrd = wb.Worksheets("PRODUCTION")
Set rAdmList = wsAdm.Range("E2", wsAdm.Cells(wsAdm.Rows.Count, "E").End(xlUp)) 'Dynamically size list
Set rPrdList = wsPrd.Range("O6", wsPrd.Cells(wsPrd.Rows.Count, "O").End(xlUp)) 'Dynamically size list
Me.ComboBox3.List = rAdmList.Value
Me.ComboBox4.List = rPrdList.Value
End Sub
Private Sub ACCEPTBUTTON_Click()
'Check if anything is selected from ComboBox4
If Me.ComboBox4.ListIndex = -1 Then
Me.ComboBox4.SetFocus
MsgBox "Must select a Production item"
Exit Sub
End If
'An item from the production list in combobox4 has been confirmed to be selected
'Search the corresonding ComboBox4 list range to find the corresponding row
'(In your original code, you are searching column A instead of the column that populated the combobox which is column O, is there a reason for that?)
Dim rFound As Range, sFirst As String
Set rFound = rPrdList.Find(Me.ComboBox4.Text, rPrdList(rPrdList.Cells.Count), xlValues, xlWhole)
If Not rFound Is Nothing Then
sFirst = rFound.Address 'Record first address of found item
Do
'Matching row found, unhide and populate cells with textbox values
'Note that there is currently no check or validation that the textboxes are populated
rFound.EntireRow.Hidden = False
wsPrd.Cells(rFound.Row, "AC").Value = Me.TextBox1.Text
wsPrd.Cells(rFound.Row, "AD").Value = Me.TextBox2.Text
wsPrd.Cells(rFound.Row, "AE").Value = Me.TextBox3.Text
wsPrd.Cells(rFound.Row, "AF").Value = Me.TextBox4.Text
wsPrd.Cells(rFound.Row, "AG").Value = Me.TextBox5.Text
wsPrd.Cells(rFound.Row, "AH").Value = Me.TextBox6.Text
wsPrd.Cells(rFound.Row, "AI").Value = Me.TextBox7.Text
wsPrd.Cells(rFound.Row, "AJ").Value = Me.TextBox8.Text
'Search for next cell that matches
Set rFound = rPrdList.FindNext(rFound)
Loop While rFound.Address <> sFirst 'Loop until back at first address
Else
'If the item wasn't found, it's because the user manually typed in something in the combobox, or other error occurred
Me.ComboBox4.SetFocus
MsgBox "Invalid value entered for Production item"
Exit Sub
End If
Unload Me
End Sub
I have encountered a few issues with some code in VBA. I am trying to have the changes made to a cells on an excel sheet show up in comments on the cell the change was made to and I wish for these changes to be stored in a list so I can view them all later. I have tried lots of different pieces of code I have found to try and implement it into the code but none have worked.
Any ideas on how to get this to work?
Worksheet
The below code is what I am currently using
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Adding As Boolean, Finding As Boolean, Subtracting As Boolean
Dim f As Range, v
Select Case Target.Address(True, True)
Case "$A$4": Adding = True
Case "$C$4": Subtracting = True
Case "$E$4": Finding = True
Case Else: Exit Sub
End Select
v = Trim(Target.Value)
If Len(v) = 0 Then Exit Sub
Set f = Me.Range("C8").Resize(1000, 1).Find(v, lookat:=xlWhole)
If Adding Then
If f Is Nothing Then
'not found: add as new row
Set f = Me.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
f.Value = v
End If
f.Offset(0, 1).Value = f.Offset(0, 1).Value + 1
doDate f.Offset(0, 2)
Target.Value = ""
ElseIf Subtracting Then
If f Is Nothing Then
MsgBox v & " not found for subtraction!"
Else
f.Offset(0, 1).Value = f.Offset(0, 1).Value - 1
doDate f.Offset(0, 3)
Target.Value = ""
End If
Else 'finding
If Not f Is Nothing Then
f.EntireRow.Select
Target.Value = ""
Else
MsgBox v & " not found."
End If
End If
If Adding Or Subtracting Then Target.Select
End Sub
Sub doDate(c As Range)
With c
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End Sub
I have implemented a few formulas on the worksheet but don't see any reason why it would matter in this situation since they only track quantity of items with the same unique identifier.
I also tried some code that added comments to the cells as they were changed that worked but always returned the previous cell value as blank. It is not actually added into the current code though.
Option Explicit
Public preValue As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Target.ClearComments
Target.AddComment.Text Text:="Previous Value was " & preValue & Chr(10) & "Revised " & Format(Date, "mm-dd-yyyy") & Chr(10) & "By " & Environ("UserName")
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target = "" Then
preValue = "a blank"
Else: preValue = Target.Value
End If
End Sub
By and large, the code below should do what you want. I marveled at your use of A4 and C4 to express addition and subtraction. As it is, whatever you change in those two cells, apart from clearing them, will result in a quantity of 1 being added or subtracted. I would have expected that a quantity must be entered there which is processed. If the quantity is fixed at 1 the system appears too elaborate.
Anyway, here's the code. I guess you'll be able to modify it to better suit your needs.
Private Sub Worksheet_Change(ByVal Target As Range)
' 038
Dim LookUp As Variant ' subject
Dim Action As Variant ' add = 1, subtract = -1, find = 2
Dim Fnd As Range ' Result of Find method
Dim Txt As String ' comment text
With Target
If (.Row <> 4) Or (.CountLarge > 1) Then Exit Sub
LookUp = Cells(4, "E").Value
On Error Resume Next
Action = Array(0, 1, 0, -1, 0, 2)(.Column)
End With
If Action And (LookUp <> "") Then
' C8 to end of column C
With Range(Cells(8, "C"), Cells(Rows.Count, "C").End(xlUp))
Set Fnd = .Find(LookUp, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows)
End With
End If
If Fnd Is Nothing Then
Select Case Action
Case -1
MsgBox """" & LookUp & """ not found.", vbInformation, "Can't subtract"
Action = -2
Case 2
MsgBox """" & LookUp & """ not found.", vbInformation, "No record"
Action = -2
Case Else
Set Fnd = Cells(Rows.Count, "C").End(xlUp).Offset(1)
Fnd.Value = LookUp
End Select
End If
With Fnd
If Abs(Action) <> 2 Then
With .Offset(0, 1)
If .Comment Is Nothing Then
.AddComment
Else
Txt = Chr(10)
End If
Txt = "Previous Qty = " & .Value & Chr(10) & _
"Revised " & Format(Date, "mm-dd-yyyy") & Chr(10) & _
"by " & Environ("UserName") & Txt
.Comment.Text Txt, 1, False
.Value = Val(.Value) + Action
With .Offset(0, 2)
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End With
ElseIf Action = 2 Then
.EntireRow.Select
End If
End With
If Action <> 2 Then Target.Select
End Sub
I have created a multiselect dropdown for Cities in my sheet 1 and the postcodes associated with the dropdown is in sheet 2.
This is how my sheet 2 looks.
1.) User is allowed to select multiple cities from the dropdown. As soon as user selects the city, I want to show in one cell the selected city and the associated postcodes. For e.g. If user selects Sion and Dadar from the dropdown then just below the dropdown user should be able to see something like this.
With the help of Vlookup i am able to retrieve either one of the value and also not able to show in a single cell with equals to sign.
2.) Also I have used VBA code from the internet to have multiple select and remove. The code works fine but I want to make some changes in it. Like when user selects two cities the value gets populated in the dropdown cell separated by "comma". I want everytime the second value to go on next line but to remain in the same cell and also dynamically adjust the row height with leaving some margin from top and bottom. I am new to VBA and don't know how exactly to get it on next line.
This is how it currently looks.
But instead of above, I want it look like this
Here is the VBA code which i have used.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Me.Range("J2, K2,L2,M2,N2")
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If InStr(1, xValue1, xValue2 & ",") > 0 Then
xValue1 = Replace(xValue1, xValue2 & ", ", "") ' If it's in the middle with comma
Target.Value = xValue1
GoTo jumpOut
End If
If InStr(1, xValue1, ", " & xValue2) > 0 Then
xValue1 = Replace(xValue1, ", " & xValue2, "") ' If it's at the end with a comma in front of it
Target.Value = xValue1
GoTo jumpOut
End If
If xValue1 = xValue2 Then ' If it is the only item in string
xValue1 = ""
Target.Value = xValue1
GoTo jumpOut
End If
Target.Value = xValue1 & ", " & xValue2
End If
jumpOut:
End If
End If
Application.EnableEvents = True
End Sub
Select Formulas » Defined Names » Name Manager
Replace the Refers to: formula with the following formula:
=OFFSET(Lookups!$A$2,0,0,COUNTA(Lookups!$A:$A)-1)
You can now go nuts with adding and removing values from the Priority list and the dropdowns will have updated values with no additional effort!
To break down the OFFSET formula usage (using List_Priority as the example):
Lookups!$A$2: start at cell $A$2 on sheet named "Lookups" which is
the first value in the list
0: stay in that same row (so still at
$A$2)
0: stay in that same column (so, again, still at $A$2)
COUNTA(Lookups$A:$A)-1: count the number of cells in column A that
have values and then subtract 1 (the heading cell: “Priority”); grab
an area that is that tall, starting with the cell currently
“selected” ($A$2)
Add the Dependent Drop Down
On the DataEntry sheet, select cell E6.
On the Ribbon, click the Data tab, then click Data Validation..
From the Allow drop-down list, choose List.
In the Source box, type an equal sign and INDIRECT function,
referring to the first data cell in the Produce Type column: ...
Click OK.
Put code on Sheet Lookup
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("E6")) Is Nothing And Target.Cells.Count = 1 Then
Application.EnableEvents = False
If Len(Target.Offset(1, 0)) = 0 Then ' (1,0) down direction (0,1) right
Target.Offset(1, 0) = Target ' (1,0) down direction (0,1) right
Else
Target.End(xlDown).Offset(1, 0) = Target ' (1,0) down direction (0,1) right
End If
Target.ClearContents
Application.EnableEvents = True
End If
End Sub
For
Sion = 400022
You can use Vlookup formula
=VLOOKUP(Table1[Segments];Table1[Segments];1;FALSE)&" = "&VLOOKUP(Table1[Segments];Sheet2!A2:B4;2;FALSE)
I am not getting how to do it for multiselect. This works only when user select single option from the dropdown
Another solution. Change Sheet name and ranges and try:
Option Explicit
Sub test()
Dim strCitys As String
Dim rng As Range
Dim arr As Variant, strResults As Variant, City As Variant
With ThisWorkbook.Worksheets("Sheet1")
strCitys = .Range("A1").Value
Set rng = .Range("D1:E3")
strResults = ""
If strCitys <> "" Then
If InStr(1, strCitys, ",") = 0 Then
strResults = Application.VLookup(strCitys, rng, 2, False)
If Not IsError(strResults) Then
.Range("B1").Value = strCitys & "=" & strResults
Else
.Range("B1").Value = strCitys & "=" & "Missing Code"
End If
Else
For Each City In Split(strCitys, ",")
strResults = Application.VLookup(Trim(City), rng, 2, False)
If Not IsError(strResults) Then
If .Range("B1").Value = "" Then
.Range("B1").Value = Trim(City) & "=" & strResults
Else
.Range("B1").Value = .Range("B1").Value & vbNewLine & Trim(City) & "=" & strResults
End If
Else
If .Range("B1").Value = "" Then
.Range("B1").Value = Trim(City) & "=" & "Missing Code"
Else
.Range("B1").Value = .Range("B1").Value & vbNewLine & Trim(City) & "=" & "Missing Code"
End If
End If
Next City
End If
Else
.Range("B1").Clear
MsgBox "Please select city/ies."
End If
End With
End Sub
Results:
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
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