I have a important question that I didn't find answer to, is it possible to increase the width and height of a check box and Is it possible to export to another sheet the check box with the values that were selected?
And is it possible to create multiple check boxes like for 500 or 1000 rows?
To your second question..............to populate multiple CheckBoxes by rows:
Sub BoxMaker()
For i = 1 To 4
ActiveSheet.CheckBoxes.Add(358.5, 50, 100, 60).Select
Next
Dim s As Shape
i = 2
For Each s In ActiveSheet.Shapes
s.Top = Cells(i, 1).Top
s.Height = Cells(i, 1).Height
s.Left = Cells(i, 1).Left
s.Width = Cells(i, 1).Width
i = i + 1
Next
End Sub
To your first question, just update the .Height and .Width
Regarding export, link the value of the checkboxes to any cells in the sheet and export these cell values ... there are plenty of descriptions here on SO how to export cell data.
To link a checkbox to a cell use
Sub test()
Dim S As Shape
Set S = ActiveSheet.Shapes(1)
S.ControlFormat.LinkedCell = "B1"
End Sub
To add this to Gary's Student's code ...
Sub BoxMaker()
For i = 1 To 4
ActiveSheet.CheckBoxes.Add(358.5, 50, 100, 60).Select
Next
Dim s As Shape
i = 2
For Each s In ActiveSheet.Shapes
s.Top = Cells(i, 1).Top
s.Height = Cells(i, 1).Height
s.Left = Cells(i, 1).Left
s.Width = Cells(i, 1).Width
' add Cell Link
' 2nd parameter of Cells(i, 2).Address sets column of linked cell ... in this case column B
s.ControlFormat.LinkedCell = Cells(i, 2).Address
i = i + 1
Next
End Sub
fields will be filled after first click to the checkboxes.
Related
CODE ANSWER (thanks to karma)
Private Sub UserForm_Initialize()
Call PopLB
End Sub
Sub PopLB()
With Sheets("helper")
.Cells.Clear
Master.UsedRange.Copy Destination:=.Range("B1")
addr = .UsedRange.Columns(1).Offset(0, -1).Address
.Range("A1").Value = Split(addr, ":")(0)
.Range("A1").AutoFill Destination:=.Range(addr), Type:=xlFillSeries
.Range(addr).Offset(0, 1).SpecialCells(xlBlanks).EntireRow.Delete '0, 1 is Request ID; 0, 2 is CTC File Number; 0, 3 is Work Order
End With
With listboxRequestsETR
.ColumnCount = 27
.ColumnWidths = "00,28,00,00,28,28,208,28,28,28," & _
"28,28,28,28,28,28,28,28,28,28," & _
"28,28,28,28,28,28,28"
LastRow = Range("A" & Rows.Count).End(xlUp).row
.RowSource = "helper!A2:AA" & LastRow
.ColumnHeads = True
End With
End Sub
I am hoping to create a UserForm that pulls data from certain columns in a main sheet Master (Sheet1) based on if there is any data within the specified column.
Ideally, the ListBox listboxRequestsETR would check if there is a Request ID available Column A, and display the data in the yellow and blue columns. In this case, Row 1 would be shown as the column heads for the ListBox, and the only row that would not transfer over to the ListBox would be Row 4.
On a separate note, I am hoping to apply the same logic to separate ListBoxes with Columns B and C, such that the condition of populating the ListBox would be based on whether there is any data in the specified cell (regardless of whether the data is General or Number).
Any help would be appreciated!
I am able to populate the ListBox with data, however when I attempt to filter the data I come up with errors. Below is the code I have so far that brings up the ListBox with all the data.
NEW CODE
Private Sub UserForm_Initialize()
Call AddDataToListBoxETR
End Sub
Private Sub AddDataToListBoxETR()
' Dim rg As Range
' Set rg = GetRangeETR
' With listboxRequestsETR
' .RowSource = rg.Address(external:=True)
' .ColumnCount = rg.Columns.Count
' .ColumnWidths = "75;90;100;110;75;125;125;100;100;100;100;100"
' .ColumnHeads = True
' .ListIndex = 0
' End With
Dim i As Long
For i = 2 To Master.Range("A100000").End(xlUp).Offset(1, 0).row
If Master.Cells(i, "A").Value <> 0 Then
Me.listboxRequestsETR.AddItem Master.Cells(i, 1).Value
Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 2) = Master.Cells(i, "D").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 3) = Master.Cells(i, "E").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 4) = Master.Cells(i, "F").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 5) = Master.Cells(i, "G").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 6) = Master.Cells(i, "H").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 7) = Master.Cells(i, "I").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 8) = Master.Cells(i, "J").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 9) = Master.Cells(i, "K").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 10) = Master.Cells(i, "L").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 11) = Master.Cells(i, "M").Value
'Me.listboxRequestsETR.List(listboxRequestsETR.ListCount - 1, 12) = Master.Cells(i, "O").Value
End If
Next i
End Sub
DESIRED OUTCOME
I recognize there is a column limit of 10, so the ability to display columns in the ListBox filtered by the condition (if Request ID is available in Row i) is what I am looking for
OLD CODE
Private Sub UserForm_Initialize()
Call AddDataToListBoxETR
End Sub
Private Sub AddDataToListBoxETR()
Dim rg As Range
Set rg = GetRangeETR
With listboxRequestsETR
.RowSource = rg.Address(external:=True)
.ColumnCount = rg.Columns.Count
.ColumnWidths = "75;90;100;110;75;125;125;100;100;100;100;100"
.ColumnHeads = True
.ListIndex = 0
End With
End Sub
Module
Option Explicit
Public Function GetRangeETR() As Range
Set GetRangeETR = Master.Range("A1").CurrentRegion
Set GetRangeETR = GetRangeETR.Offset(1).Resize(GetRangeETR.Rows.Count - 1)
End Function
I'm still not sure if I understand you correctly. Anyway, below is just my guess about what you want .....
The LB (ListBox) in the userform will show only the row with value in column A, hide column B and C, then show column D to Z. So, in the LB, there is H01 and then H04 to H26 while the row is coming from row 2,3,5 and 6. The LB doesn't show row 4 and 7 because in column A those rows are blank/no-value.
In the Userform there are 5 textbox to update/edit the row(N) of data for H04,H05,H06,H11 and H12.
Example:
The user click one item in the LB.
Then the textbox (tb) 1 to 5 show the corresponding column value which is clicked.
Then the user update/change the value in each tb, then click UPDATE button. The DATA is updated and the LB also updated.
Private Sub UserForm_Initialize()
Call PopLB
End Sub
Sub PopLB()
With Sheets("helper")
.Cells.Clear
Sheets("DATA").UsedRange.Copy Destination:=.Range("B1")
addr = .UsedRange.Columns(1).Offset(0, -1).Address
.Range("A1").Value = Split(addr, ":")(0)
.Range("A1").AutoFill Destination:=.Range(addr), Type:=xlFillSeries
.Range(addr).Offset(0, 1).SpecialCells(xlBlanks).EntireRow.Delete
End With
With LB
.ColumnCount = 27
.ColumnWidths = "00,28,00,00,28,28,28,28,28,28," & _
"28,28,28,28,28,28,28,28,28,28," & _
"28,28,28,28,28,28,28"
.RowSource = "helper!" & Sheets("helper").UsedRange.Address
End With
End Sub
Private Sub LB_Click()
tb1.Value = LB.List(LB.ListIndex, 4)
tb2.Value = LB.List(LB.ListIndex, 5)
tb3.Value = LB.List(LB.ListIndex, 6)
tb4.Value = LB.List(LB.ListIndex, 11)
tb5.Value = LB.List(LB.ListIndex, 12)
End Sub
Private Sub bt_Click()
If LB.ListIndex = -1 Then Exit Sub
With Sheets("DATA")
r = Range(LB.List(LB.ListIndex, 0)).Row
.Cells(r, 4).Value = tb1.Value
.Cells(r, 5).Value = tb2.Value
.Cells(r, 6).Value = tb3.Value
.Cells(r, 11).Value = tb4.Value
.Cells(r, 12).Value = tb5.Value
End With
Call PopLB
End Sub
In PopLB sub, first it clear the whole cells in sheet "helper".
Then it copy the data in sheet "DATA" to sheet "helper" cell B1.
Within sheet "helper":
it get the address of the usedrange as addr variable, then put the first split value of addr in cell A1, fill series the range of addr, then finally it delete the blank row of H01
within the LB:
It make 27 columns and set each column width. Please note that there are three zero value for the column width. One is to hide the id/row in column A, the other two is to hide H02 and H03. Finally it use the sheet helper used range as the row source for the LB.
The sub LB_Click will be triggered when the user click any item in the LB. It will populate textbox (tb) 1 to 5.
The bt_Click sub will be triggered when the user click the UPDATE button. It will update the corresponding value in the sheet DATA from the tb1 to tb5 value in the userform, then it call back the PopLB sub.
so, as you said :
this UF is meant to connect with an additional UF that can edit /
delete data in selected rows.
Although maybe it's not exactly what you mean, but this UF still can update/edit the data in sheet DATA although it use a helper sheet.
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'm trying to hide columns if their headings match a checkbox name. These ActiveX checkboxes have been created based on the column headings provided.
For iCol = colNum To totalColumns
Set colCheckbox = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1")
With colCheckbox
.Left = Cells(iCol + 2, 1).Left
.Top = Cells(iCol + 2, 1).Top
.Width = Cells(iCol + 2, 1).Width * 0.8
.Height = Cells(iCol + 2, 1).Height * 0.8
.Name = "cbx" & iCol
.Object.Caption = Cells(RowNum, iCol).Value
End With
Next iCol
When the checkboxes are selected / deselected the code below will find the column heading and hide the column.
Private Sub CheckBox1_Click()
Set matchingAddress = Rows("4").Find(CheckBox1.Caption, LookIn:=xlFormulas)
If matchingAddress Is Nothing Then
MsgBox ("Column Not Found")
Else
cellAddressSplit = Split(matchingAddress.Address, "$")
Columns(cellAddressSplit(1)).EntireColumn.Hidden = Not CheckBox1
End If
End Sub
I'm trying to move this code to a module, so that I can just pass the checkbox name (CheckBox1.Name) to the module function and manipulate the checkbox's visibility. I'm looking at 40 plus columns on the sheet and I want the same code in all Click methods. I'm trying to replace CheckBox1 with
Set cBox = ActiveSheet.CheckBoxes(Application.Caller)
or
Set cBox = ActiveSheet.Shapes(Application.Caller)
These are not working. Please provide directions. Should I be using forms instead of ActiveX checkboxes?
A sample error I get is "Unable to get checkboxes property of the worksheet class"
Sub CreateCheckBox()
colNum = 1
totalColumns = 3
RowNum = 8
For iCol = colNum To totalColumns
Set colCheckBox = ActiveSheet.CheckBoxes.Add(305.25, 158.25, 62.25, 17.25)
With colCheckBox
.Left = Cells(iCol + 2, 1).Left
.Top = Cells(iCol + 2, 1).Top
.Width = Cells(iCol + 2, 1).Width * 0.8
.Height = Cells(iCol + 2, 1).Height * 0.8
.Name = "cbx" & iCol
.Characters.Text = Cells(RowNum, iCol).Value
.OnAction = "HideColumn"
End With
Next
End Sub
Sub HideColumn()
Set cBox = ActiveSheet.CheckBoxes(Application.Caller)
Set matchingAddress = Rows(8).Find(cBox.Caption, LookIn:=xlFormulas)
If matchingAddress Is Nothing Then
MsgBox ("Column Not Found")
Else
If Columns(matchingAddress.Column).EntireColumn.Hidden = True Then
Columns(matchingAddress.Column).EntireColumn.Hidden = False
Else
Columns(matchingAddress.Column).EntireColumn.Hidden = True
End If
End If
End Sub
I am relatively new to VBA and am working on creating some forms to help with inventory management.
When the form is initialized, there is a listbox that will pull product information from an inventory sheet. Each row has 11 columns with information like product ID, vendor, price, items in stock, etc. There are also three checkboxes - Items Below Par, Items At Par, and Items Above Par. The 3 checkbox values are set to True to begin because all Inventory is being displayed in the listbox when the form is initialized.
I am trying to write code that will remove products from the listbox when one of the checkboxes are unchecked. For example, if I uncheck "Items Below Par" I want all products where the # of items in stock is < the par value for that item (which is another column) to be removed. This would leave the listbox only displaying those items that are at or above par.
How would I go about doing this? I am not sure how to reference the values in the listbox columns.
Thank you in advance!! Please ask questions if this is unclear.
Private Sub UserForm_Initialize()
Dim lr As Long
Dim Inv As Worksheet
Dim rng As Range
Set Inv = Sheets("Inventory")
lr = Inv.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Inv.Range("A2:K" & lr)
Me.lbInventory.ColumnCount = 11
Me.lbInventory.RowSource = rng.Address
Me.lbInventory.ColumnHeads = True
Me.chkAbove.Value = True
Me.chkBelow.Value = True
Me.chkAt.Value = True
End Sub
Private Sub chkAbove_Change()
ListBuild
End Sub
Private Sub chkAt_Change()
ListBuild
End Sub
Private Sub chkBelow_Change()
ListBuild
End Sub
Sub ListBuild()
Dim Inv As Worksheet
Set Inv = Sheets("Inventory")
Dim r As Integer
Me.lbInventory.Clear
If Me.chkBelow.Value = True Then
For r = 1 To 11
If Inv.Cells(r, 7).Value <
Inv.Cells(r, 9).Value Then
Me.lbInventory.AddItem Inv.Cells(r, 1).Value
End If
Next r
End If
If Me.chkAt.Value = True Then
For r = 1 To 11
If Inv.Cells(r, 7).Value =
Inv.Cells(r, 9).Value Then
Me.lbInventory.AddItem Inv.Cells(r, 1).Value
End If
Next r
End If
If Me.chkAbove.Value = True Then
For r = 1 To 11
If Inv.Cells(r, 7).Value >
Inv.Cells(r, 9).Value Then
Me.lbInventory.AddItem Inv.Cells(r, 1).Value
End If
Next r
End If
End Sub
I am getting a Compile error. Expected expression for these 3 statements:
If Inv.Cells(r, 7).Value >,<,=
Inv.Cells(r, 9).Value Then
There may be a cleaner way and I encourage anyone who has a cleaner way to join in, but this seems to work. Basically, rebuild the listbox list under the change event of each check box. Below I have an example assuming the checkboxes are named BelowPar, AtPar, & AbovePar.
Private Sub AbovePar_Change()
ListBuild
End Sub
Private Sub AtPar_Change()
ListBuild
End Sub
Private Sub BelowPar_Change()
ListBuild
End Sub
Sub ListBuild()
Dim r As Integer
InventoryList.Clear
If BelowPar.Value = True Then
For r = 1 To 11
If Sheets("InventorySheet").Cells(r, 2).Value < _
Sheets("InventorySheet").Cells(r, 3).Value Then
InventoryList.AddItem Sheets("InventorySheet").Cells(r, 1).Value
End If
Next r
End If
If AtPar.Value = True Then
For r = 1 To 11
If Sheets("InventorySheet").Cells(r, 2).Value = _
Sheets("InventorySheet").Cells(r, 3).Value Then
InventoryList.AddItem Sheets("InventorySheet").Cells(r, 1).Value
End If
Next r
End If
If AbovePar.Value = True Then
For r = 1 To 11
If Sheets("InventorySheet").Cells(r, 2).Value > _
Sheets("InventorySheet").Cells(r, 3).Value Then
InventoryList.AddItem Sheets("InventorySheet").Cells(r, 1).Value
End If
Next r
End If
End Sub
Adjust ranges and sheet name to suit your needs. For this example Cells(r, 1).Value = Item name, Cells(r, 2).Value = # of items in stock, and Cells(r, 3).Value = Par Value. Where 1, 2, 3 are the column number containing the data.
Could someone please help me with some code to delete all duplicate entries across multiple columns and rows. Any cell which has a duplicate value I'd like to be blank, but I do not want to delete the cell and shift all the rows up like the remove duplicates button does. I'd like code exactly like conditional formatting does to highlight cells, but I'd like to set the value to "" instead.
I'm trying to edit the macro I recorded to something like:
Columns("I:R").Select
selection.FormatConditions.AddUniqueValues
selection.FormatConditions(1).DupeUnique = xlDuplicate
selection.FormatConditions(1).Value = ""
But I'm not sure I'm on the right track
Start at the bottom and work towards the top. Take a ten-column-conditional COUNTIFS function of the cell values while shortening the rows examined by 1 every loop.
Sub clearDupes()
Dim rw As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With Intersect(.Range("I:R"), .UsedRange)
.Cells.Interior.Pattern = xlNone
For rw = .Rows.Count To 2 Step -1
With .Resize(rw, .Columns.Count) 'if clear both then remove this
If Application.CountIfs(.Columns(1), .Cells(rw, 1), .Columns(2), .Cells(rw, 2), _
.Columns(3), .Cells(rw, 3), .Columns(4), .Cells(rw, 4), _
.Columns(5), .Cells(rw, 5), .Columns(6), .Cells(rw, 6), _
.Columns(7), .Cells(rw, 7), .Columns(8), .Cells(rw, 8), _
.Columns(9), .Cells(rw, 9), .Columns(10), .Cells(rw, 10)) > 1 Then
'test with this
.Rows(rw).Cells.Interior.Color = vbRed
'clear values with this once it has been debugged
'.Rows(rw).Cells.ClearContents
End If
End With 'if clear both then remove this
Next rw
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I've left some code in that only marks the potential duplicates. When you are happy with the results, change that to the commented code that actually clear the cell contents.
Using two sets of nested loops I check each cell in the range twice, once to see if it was a duplicate and to mark it and a second time to then remove the value (ensuring I remove all duplicates and do not leave one instance of each duplicate).
I'm sure that this is an inefficient way of doing it but it works so hopefully helps someone else in the same boat.
Private Sub CommandButton1_Click()
Dim Row As Integer
Dim Column As Integer
Row = 100
Column = 10
'loop through identifying the duplicated by setting colour to blue
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Application.CountIf(Range(Cells(4, 1), Cells(Row, Column)), Cells(i, j)) > 1 Then 'check each cell against entire range to see if it occurs more than once
Cells(i, j).Interior.Color = vbBlue 'if it does sets it to blue
End If
Next j
Next i
'loop through a second time removing the values in blue (duplicate) cells
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Cells(i, j).Interior.Color = vbBlue Then 'checks if cell is blue (i.e duplicate from last time)
Cells(i, j) = "" 'sets it to blank
Cells(i, j).Interior.Color = xlNone 'changes colour back to no fill
End If
Next j
Next i
End Sub
Use conditional format to highlight duplicates and then change the value to "" using a loop through selection.
This code will allow one value to remain.(if you have 25 twice, this code will keep one 25)
Option Explicit
Sub DupRem()
Application.ScreenUpdating = False
Dim rn As Range
Dim dup As Range
Columns("I:R").FormatConditions.AddUniqueValues
Columns("I:R").FormatConditions(1).DupeUnique = xlDuplicate
Columns("I:R").FormatConditions(1).Font.Color = RGB(255, 255, 0)
For Each rn In Columns("I:R").Cells
If rn <> "" Then
If rn.DisplayFormat.Font.Color = RGB(255, 255, 0) Then
If dup Is Nothing Then
Set dup = rn
Else
Set dup = Union(dup, rn)
End If
End If
End If
Next
dup.ClearContents
Columns("I:R").FormatConditions(1).StopIfTrue = False
Columns("I:R").FormatConditions.Delete
Application.ScreenUpdating = True
End Sub