I have the following code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count = 1 Then
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Dim cb As Object
Dim combineRange As Range
Dim boolStr As String
Dim floatStr As String
Dim booleanRange As Range
Dim floatRange As Range
Dim bRow As Integer
bRow = Worksheets("DEF_BOOLEAN").Cells(Rows.Count, 1).End(xlUp).Row
Dim fRow As Integer
fRow = Worksheets("DEF_FLOAT").Cells(Rows.Count, 1).End(xlUp).Row
boolStr = "A2:A" & bRow
floatStr = "A2:A" & fRow
Set booleanRange = Worksheets("DEF_BOOLEAN").Range(boolStr)
Set floatRange = Worksheets("DEF_FLOAT").Range(floatStr)
Set cb = Worksheets("FT_CASE_xx").OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, DisplayAsIcon:=False, Left:=Target.Left, Top:=Target.Top, Width:=Target.Width, Height:=Target.Height).Object
For Each cell In booleanRange
cb.AddItem cell.value
Next cell
For Each cell In floatRange
cb.AddItem cell.value
Next cell
End If
End If
End Sub
which adds an ActiveX combobox each time I press on a Cell in the 'A' column.
That's work fine. The problem is that I would like the cell below (the one 'covered' by the combobox) get the value selected in the combobox.
That's why I thought to use the linkedCell property. unfortunately the following lines don't work:
cb.LinkedCell = Target
or
cb.LinkedCell = Target.address
How should it be set to achieve the result?
A slight change worked for me: change Dim cb As Object to Dim cb as ComboBox.
Then use cb.LinkedCell = Target.Address.
Related
So I have some code that comments on cells based on information beside of it and it is working almost flawlessly. However, I am having an issue where it is working on all sheets in the entire workbook instead of just sheet 3 like it is supposed to. I have this code set up on sheet 3 only in the VBA projects. So my question is how would I make this work only on one single sheet?
Here is my code
Private Sub Worksheet_Calculate()
ActiveSheet.UsedRange.ClearComments
Dim targetRng As Range, commentSrcRng As Range
Dim strPrefix As String 'string Prefix
Set targetRng = Application.Range("D16,D18,D20,D22,D24,D26,D28,D30,D32,D34,D36,D38")
Set commentSrcRng = targetRng.Offset(0, 1)
Dim cel As Range
Dim i As Long
i = 1
For Each cel In targetRng
If cel <> "" Then
cel.AddComment
cel.Comment.Visible = False
cel.Comment.Shape.TextFrame.AutoSize = True
cel.Comment.Text strPrefix & commentSrcRng.Cells(i)
End If
i = i + 2
Next
However, I am having an issue where it is working on all sheets in the entire workbook
That's because you've coded it to work on the ActiveSheet
To refer to the sheet the event is coded in, use Me
Private Sub Worksheet_Calculate()
Me.UsedRange.ClearComments
Dim targetRng As Range, commentSrcRng As Range
Dim strPrefix As String 'string Prefix
Set targetRng = Me.Range("D16,D18,D20,D22,D24,D26,D28,D30,D32,D34,D36,D38")
Set commentSrcRng = targetRng.Offset(0, 1)
Dim cel As Range
Dim i As Long
i = 1
For Each cel In targetRng
If cel <> "" Then
cel.AddComment
cel.Comment.Visible = False cel.Comment.Shape.TextFrame.AutoSize = True
cel.Comment.Text strPrefix & commentSrcRng.Cells(i)
End If
i = i + 2
Next
End Sub
I am creating a VBA Excel program where I can copy the cell value to another sheet if its corresponding checkbox is checked. I have 278 "number" entries in one column and an corresponding individual "checkboxes" in one column. But when click the checkbox, the corresponding row text is not displayed.Instead it shows only the first 5 column values. For example, If I select 5 checkboxes randomly, it shows 1,2,3,4,5 numbers are displayed in the "sheet 2" columns.
Sub Button21_Click()
Dim chkbx As CheckBox
Dim i As Integer
a = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = xlOn Then
Worksheets("sheet1").Cells(i, 1).Copy
Worksheets("sheet2").Activate
b = Worksheets("sheet2").Cells(i, 1).End(xlUp).Row
Worksheets("sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
i = i + 1
End If
Next chkbx
Next i
End Sub
This is the code I've used.
Any help would be appreciated.
An Objects Investigation
The Solution
The TopLeftCell Solution, The Solution, is based on the idea of Tim Williams suggested in the comments.
This will be in your sheet code (Sheet1).
Sub Button21_Click()
executeCheckBoxes
End Sub
The rest will be in a standard module (e.g. Module1).
Sub executeCheckBoxes()
Dim src As Worksheet ' Source Worksheet (Object)
Dim tgt As Worksheet ' Target Worksheet (Object)
Dim chkbx As CheckBox ' CheckBox (For Each Control Variable)
Dim srcLR As Long ' Source Last Row
Dim tgtER As Long ' Target Empty Row
Dim i As Long ' Source Row Counter
Set src = ThisWorkbook.Worksheets("Sheet1")
Set tgt = ThisWorkbook.Worksheets("Sheet2")
srcLR = src.Cells(src.Rows.Count, 1).End(xlUp).Row
tgtER = tgt.Cells(tgt.Rows.Count, 1).End(xlUp).Row + 1
For Each chkbx In src.CheckBoxes
If chkbx.Value = xlOn Then
' Cell Version
tgt.Cells(tgtER, 1).Value = _
src.Cells(chkbx.TopLeftCell.Row, 1).Value
' The following 2 ideas are not so good. They are running into trouble
' when adding new checkboxes if not sooner.
' Index Version
' Assuming the index of the checkbox is 1 for row 2, 2 for 3 etc.
' Adjust the "+1" as needed.
' tgt.Cells(tgtER, 1).Value = src.Cells(chkbx.Index + 1, 1).Value
' Name Version
' Assuming the name of the checkbox is "Check Box 1" for row 2,
' "Check Box 2" for 3 etc. Adjust the "+1" as needed.
' tgt.Cells(tgtER, 1).Value = src.Cells(Val(Right(chkbx.Name, _
' Len(chkbx.Name) - Len("Check Box "))) + 1, 1).Value
tgtER = tgtER + 1
Debug.Print chkbx.Name
End If
Next chkbx
End Sub
Extras
The following are codes used to help to create the two inferior solutions.
Sub deleteCB()
deleteCheckBoxes ThisWorkbook.Worksheets("Sheet1")
End Sub
' Deletes all check boxes on a worksheet.
' Note: When you delete all check boxes, the 'counter' is not reset i.e. if you
' e.g. had "Check Box 100" the next check box will be named "Check Box 101".
' But after you save and close the workbook and open it again,
' the first check box name will be "Check Box 1".
Sub deleteCheckBoxes(Sheet As Worksheet)
Sheet.CheckBoxes.Delete
End Sub
' Creates check boxes in a range.
Sub addCheckBoxes()
Const SheetName As String = "Sheet1"
Const chkRange As String = "B2:B279"
Const chkCaption As String = "Chk"
Dim chk As CheckBox, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets(SheetName)
Set rng = .Range(chkRange)
For Each cel In rng.Cells
Set chk = .CheckBoxes.Add(cel.Left, cel.Top, cel.Width, cel.Height)
With chk
.Caption = chkCaption & i
End With
i = i + 1
Next
End With
End Sub
Sub showSomeCheckBoxProperties()
Dim chk As CheckBox, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1")
For Each chk In .CheckBoxes
With chk
Debug.Print .BottomRightCell.Address, .Caption, _
.Characters.Count, .Enabled, .Index, .Name, .Placement, _
.Text, .TopLeftCell.Address, .Value, .Visible
End With
Next
End With
End Sub
Extras 2
The following is the code based on the YouTube video
Add Button to Worksheet and Assign a Macro to it -Excel Help by XLorate that helped quite a lot in answering this question.
Sub addButtons()
Dim btn As Button, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A1:A3")
For Each cel In rng.Cells
Set btn = .Buttons.Add(cel.Left, cel.Top, cel.Width, cel.Height)
With btn
.Caption = "Macro" & i
.OnAction = "Macro" & i
End With
i = i + 1
Next
End With
End Sub
The following are some other more or less helpful codes which I created while investigating objects.
Sub showSomeShapesProperties()
Dim ws As Worksheet, sh As Shape
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each sh In ws.Shapes
With sh
If sh.Type = 12 Then
Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
End If
If sh.Type = 8 Then
Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
End If
End With
Next
End Sub
Sub showSomeOleObjectProperties()
Dim ws As Worksheet, oo As OLEObject
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each oo In ws.OLEObjects
With oo
Debug.Print .Name, .OLEType, .AutoLoad, .Enabled, .Index, _
.BottomRightCell.Address
End With
Next
End Sub
Sub addOLECheckBoxes()
Const srcName As String = "Sheet1"
Dim chk As OLEObject, rng As Range, cel As Range, i As Long
With ThisWorkbook.Worksheets(srcName)
Set rng = .Range("A1:A10")
i = 1
For Each cel In rng.Cells
Set chk = .OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=cel.Left, Top:=cel.Top, Width:=cel.Width, Height:=cel.Height)
With chk
'.Name = "Chk" & i
'.Placement = xlMoveAndSize
End With
i = i + 1
Next cel
End With
End Sub
I have two buttons, "multiply by 0" and "show original value".
For the "multiply by 0" button, I have the below code, which works fine. What I need help with is the code for the second button, which would make the range that is multiplied by 0 back to its original number).
Public Sub MultiplyByZero()
Dim rngData As Range
Set rngData = ThisWorkbook.Worksheets("Input Sheet LC").Range("I76:O103")
rngData = Evaluate(rngData.Address & "*0")
End Sub
Thanks for your help!
The below code may helps you.
Declare a global variable named arr so you can call it from anywhere - Dim arr As Variant
Before you multiple by zero we store the values in that array - arr = .Range("A1:A5")
At any time we can bring the values back - .Range("B1:B5").Value = arr
Option Explicit
Dim arr As Variant
Public Sub MultiplyByZero()
Dim rngData As Range
Dim cell As Range
With ThisWorkbook.Worksheets("Sheet1")
arr = ""
Set rngData = .Range("A1:A5")
arr = .Range("A1:A5")
rngData = Evaluate(rngData.Address & "*0")
End With
End Sub
Public Sub RestoreValues()
With ThisWorkbook.Worksheets("Sheet1")
If Not IsEmpty(arr)=True Then
.Range("A1:A5").Value = arr
Else
MsgBox "Array is empty."
End If
End With
End Sub
Using a formula instead of a constant:
Public Sub MultiplyByZero()
Dim rngData As Range, rngWork AS Range
Set rngData = ThisWorkbook.Worksheets("Input Sheet LC").Range("I76:O103")
For Each rngWork In rngData.Cells
With rngWork
If .HasFormula Then
If Right(.Formula,2) <> "*0" Then .Formula = .Formula & "*0"
Else
.Formula = "=" & .Value & "*0"
End If
End With
Next rngWork
End Sub
Public Sub DivideByZero()
Dim rngData As Range, rngWork AS Range
Set rngData = ThisWorkbook.Worksheets("Input Sheet LC").Range("I76:O103")
For Each rngWork In rngData.Cells
With rngWork
If .HasFormula Then
If Right(.Formula,2) = "*0" Then .Formula = Mid(.Formula, 1, Len(.Formula)-2)
End If
End With
Next rngWork
End Sub
This will change 10 into =10*0 and then back into =10
In my Sheet 1, Column A has some values and I need to create a Active X checkbox for all the values in Sheet 2 in a specific cell. First I need to check whether Active X checkbox is there for the value or not, If its not there, I need to create. I already tried the below code, But its creating the duplicate checkboxes.
Sub Addcheckbox()
Dim rng As Range, cell As Range
Dim rr As Integer
Dim tf As Boolean
Dim shpTemp As Shape
Set rng = Range("A1:A8")
Set Destrng = Range("A2:A9")
rr = 2
For Each cell In Worksheets("Sheet1").Range("A1:A8")
If Not IsEmpty(cell.Value) Then
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=51.75, Top:=183, Width:=120, Height:=19.5)
.Object.Caption = cell.Value
End With
End If
rr = rr + 1
Next cell
End Sub
How to check whether ActiveX checkbox already present in the sheet or not with Caption name
i tried this code for checking the checkboxes.. But its not working..
Function shapeExists(ByRef shapename As String) As Boolean
shapeExists = False
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.name = shapename Then
shapeExists = True
Exit Function
End If
Next sh
End Function
ActiveX Checkboxes are OleObjects. Is this what you are trying?
Also you need to specify the correct .Top else they will be created at the same place. See how I used Top:=cell.Top
Sub Sample()
Dim rng As Range, cell As Range
Dim rr As Integer
Dim tf As Boolean
Dim shpTemp As Shape
Set rng = Range("A1:A8")
Set Destrng = Range("A2:A9")
rr = 2
For Each cell In Worksheets("Sheet1").Range("A1:A8")
If Not IsEmpty(cell.Value) Then
If Not CBExists(cell.Value) Then '<~~ Check if the checkbox exists
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=51.75, Top:=cell.Top, Width:=120, Height:=19.5)
.Object.Caption = cell.Value
End With
End If
End If
rr = rr + 1
Next cell
End Sub
'~~> Function to check if the checkbox exists
Function CBExists(s As String) As Boolean
Dim oleObj As OLEObject
Dim i As Long
For i = 1 To Worksheets("Sheet1").OLEObjects.Count
If s = Worksheets("Sheet1").OLEObjects(i).Object.Caption Then
CBExists = True
Exit Function
End If
Next i
End Function
I'm new to VBA and am having issues with Range syntax and what are acceptable arguments.
the purpose of this code is as follows:
user inputs value into cell D5 on Sheet2
User activates code with button
searches "configs" sheet for value
copies corresponding range after locating value
pastes range back into Sheet2
the range I am attempting to copy paste is a block that starts with the selected cell (D5) on sheet "Configs", and continues until an empty cell is found.
Sub search()
Dim GCell As Range,
Dim box As Integer
Dim Avio As String
Dim Sheet2 As Worksheet, Configs As Worksheet
Dim rw1 As String, rw2 As String
Set Configs = ActiveWorkbook.Sheets("Configs")
Set Sheet2 = ActiveWorkbook.Sheets("Sheet2")
Avio = Range("D5").Value
Set GCell = Configs.Cells.Find(Avio)
box = 0
LoopX:
box = box + 1
If GCell.Offset(box, 0).Value = "" Then
rw1 = GCell.Offset(1, -1).Address
rw2 = GCell.Offset(box, 2).Address
Configs.Range("rw1:rw2").Copy <-- this syntax doesnt seem to work...
Sheet2.Range("Avio.Offset(1,0)").Paste <-- I know this is wrong, but I would like the range to be pasted just below the selected cell on Sheet2
Else: GoTo LoopX
End If
End Sub
Is this helping?
Sub search()
Dim GCell As Range
Dim box As Integer
Dim Sheet2 As Worksheet, Configs As Worksheet
Dim rw1 As String, rw2 As String
Set Configs = ActiveWorkbook.Sheets("Configs")
Set Sheet2 = ActiveWorkbook.Sheets("Sheet2")
Dim rngAvio As Range
Set rngAvio = Sheet2.Range("D5")
Set GCell = Configs.Cells.Find(rngAvio.Value)
box = 0
Do While (GCell.Offset(box, 0).Value <> "")
box = box + 1
rw1 = GCell.Offset(1, -1).Address
rw2 = GCell.Offset(box, 2).Address
Configs.Range(rw1 & ":" & rw2).Copy rngAvio.Offset(1, 0)
Loop
End Sub