I am working on a sheet that have day to day sales data. I need to summaries the data between a specific date. for this I want to use a user form with 2 combo box (I have never worked with user forms & controls ever before). I added the items into combo box by using below codes -
Private Sub UserForm_Initialize()
ComboBox1.RowSource = "A2:A6724"
ComboBox2.RowSource = "A2:A6724"
End Sub
this worked fine. But here is a problem that it is repeating the same items many time as there are many transactions in same date in the sheet.
To solve this issue I search help in internet & found a procedure, I modify that and used in my code. that's working correctly but it also has a little problem that as I click on a date from drop down list of combo box it changes the date format (i.e. if I select 10/12/2016 it shows 12-oct-2016 but it should be 10-dec-2016)
here is the code I modify actually I don't know what it does but I think is will work for me-
Private Sub UserForm_Initialize()
'ComboBox1.RowSource = "A2:A6724"
'ComboBox2.RowSource = "A2:A6724"
Dim Coll As Collection, cell As Range, LastRow As Long
Dim blnUnsorted As Boolean, i As Integer, temp As Variant
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets("Sheet1")
LastRow = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set Coll = New Collection
With ComboBox1
.Clear
For Each cell In SourceSheet.Range("A2:A" & LastRow)
If Len(cell.Value) <> 0 Then
Err.Clear
Coll.Add cell.Text, cell.Text
If Err.Number = 0 Then .AddItem cell.Text
End If
Next cell
End With
Set SourceSheet = Worksheets("Sheet1")
LastRow = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set Coll = New Collection
With ComboBox2
.Clear
For Each cell In SourceSheet.Range("A2:A" & LastRow)
If Len(cell.Value) <> 0 Then
Err.Clear
Coll.Add cell.Text, cell.Text
If Err.Number = 0 Then .AddItem cell.Text
End If
Next cell
End With
Set Coll = Nothing
Set SourceSheet = Nothing
End Sub
I will be greatly Thankful for any help.
Try following code, that use a dictionary.
Public dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Private Sub UserForm_Initialize()
Dim i As Integer
Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
cU1 = Worksheets("Sheet1").Range("A2:A" & lrU) 'Starts in second row. First row left for titles
For iU1 = 1 To UBound(cU1, 1)
dU1(cU1(iU1, 1)) = 1
Next iU1
'now dU1 has unique values from column A
For i = 0 To dU1.Count - 1
ComboBox1.AddItem dU1.Keys()(i) 'Load Combobox1 with unique values from Column A
Next
End Sub
Private Sub ComboBox1_Change()
Dim lLastRow As Long
Dim i As Integer
ComboBox2.Clear
For i = 0 To dU1.Count - 1
If CDate(ComboBox1.Value) < CDate(dU1.Keys()(i)) Then
ComboBox2.AddItem dU1.Keys()(i) 'Load Combobox2
End If
Next
End Sub
Related
I have an automatically generated listbox with checkboxes. I now want this listbox to check if certain values appear in a range and select these on the listbox.
How do I do this?
I have the following code set up to generate the listbox with values:
Private Sub UserForm_Initialize()
Dim lbtarget As MSForms.ListBox
Dim rngSource As Range
Dim curColumn As Long
Dim LastRow As Long
curColumn = 1
LastRow = Worksheets("Hidden_Classes").Cells(Rows.Count, curColumn).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("Hidden_Classes").Range("A2:A" & LastRow)
'Fill the listbox
Set lbtarget = Me.lstCheckBoxes
With lbtarget
.ListStyle = fmListStyleOption
.MultiSelect = fmMultiSelectMulti
'Insert the range of data supplied
.List = rngSource.Value
End With
End Sub
The items I need to be selected on the listbox appear on the folowing Range:
Worksheets("Hidden_Classes").Range("P2:P15")
As i mentioned in the comment to the question, you have to loop through the items in a ListBox and the values in the column P.
Dim wsh As Worksheet
Dim SecondLastRow As Integer, i As Integer, j As Integer
Set wsh = Worksheets("Hidden_Classes")
'change your code here to use [wsh] variable instead of [Worksheets("Hidden_Classes")]
'add below lines right after [End With]
SecondLastRow = wsh.Range("P" & wsh.Rows.Count).End(xlUp).Row
For i = 0 To lbtarget.ListCount -1
For j = 2 To SecondLastRow
If wsh.Range("A" & i+2) = wsh.Range("P" & j) Then
lbtarget.Selected(i) = True
Exit For 'value has been found and selected, you can skip second [for] loop
End If
Next j
Next i
Should be easy, try:
For i=2 to LastRow
'Customize your condition for adding them to the listbox or just skip the IF if you want to add them all
If Worksheets("Hidden_Classes").Cells(i,"A") = "Condition" Then
lbtarget.AddItem Worksheets("Hidden_Classes").Cells(i,"A")
End If
Next i
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 want to populate unique values into combobox.
My sheet details
Code:
Private Sub ComboBoxscname_DropButtonClick()
With Worksheets("A1")
ComboBoxscname.List = .Range("B2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
End Sub
I have highlighted with yellow which are duplicated for column "B" and should be displayed only once in combobox.
Another solution I have but getting error when selecting specific sheet name.
Sub ComboBoxscnameList()
Dim LR As Long
Dim ctrl As Object
'Set ctrl = Sheets("A1").Select
LR = Cells(Rows.Count, "B").End(xlUp).Row
ctrl.List() = CreateArray(Range("B2:B" & LR))
End Sub
'creates an array from a given range
'ignores blanks and duplicates
Function CreateArray(r As Range)
Dim col As New Collection, c As Range, TempArray(), i As Long
'for each cell in range r
For Each c In r
On Error Resume Next
col.Add c.Value, CStr(c.Value)
If Err.Number = 0 And Trim(c) <> "" Then
ReDim Preserve TempArray(i)
TempArray(i) = c.Value
i = i + 1
End If
Err.Clear
Next
CreateArray = TempArray
Erase TempArray
End Function
Private Sub ComboBoxscname_DropButtonClick()
Call ComboBoxscnameList
End Sub
The easiest way to save a unique set of values from a Column or Range is by using a Dictionary. You loop though your cells in column B, and check if each one is already in the Dictionary keys, the syntax is Dict.Exists("your_parameters").
You can read more about using Dictionary HERE.
Review the modified code below, you want to add it to your UserForm_Initialize() event.
Modified Code
Private Sub UserForm_Initialize()
Dim i As Long, ArrIndex As Long, LastRow As Long
Dim Dict As Object, Key As Variant
Dim HSNArr() As String
Application.ScreenUpdating = False
' us a Dictionary, and save unique Eco-System as array
Set Dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet2") ' <-- modify to your sheet's name
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
ReDim HSNArr(1 To LastRow) ' redim HSN array >> will optimize size later
ArrIndex = 1
For i = 2 To LastRow
If Not Dict.Exists(.Range("B" & i).Value2) And Trim(.Range("B" & i).Value2) <> "" Then ' make sure not in Dictionary and ignore empty cells
Dict.Add .Range("B" & i).Value2, .Range("B" & i).Value2 ' add current HSN
HSNArr(ArrIndex) = .Range("B" & i).Value2
ArrIndex = ArrIndex + 1
End If
Next i
End With
ReDim Preserve HSNArr(1 To ArrIndex - 1) ' resize to populated size of Array
Application.ScreenUpdating = True
With Me.ComboBoxscname
.Clear ' clear previous combo-box contents
For i = 1 To UBound(HSNArr) ' loop through array, add each unique HSN to Combo-Box
.AddItem HSNArr(i)
Next i
' show default value
.Value = HSNArr(1)
End With
End Sub
I am trying to create a subroutine to delete duplicates out of comboboxes. I input a number in place of X when I called the subroutine. I keep getting an error that tells me "Object Required" when i get to the subroutine. I know that means that something is not being properly initialized, but I cannot figure out how to fix my issue. Any help would be greatly appreciated. Thank you.
Private Sub UserForm_Initialize()
'ComboBox Populate
Dim rngNext As Range
Dim myRange As Range
Dim C As Integer
With Sheets("KEY")
Set rngNext = .Range("B500").End(xlUp).Offset(1, 0)
End With
rngNext.Select
Set myRange = Range("B2", rngNext)
With ComboBox1
For Each rngNext In myRange
If rngNext <> "" Then .AddItem rngNext
Next rngNext
End With
Call RemoveDuplicates(1)
End sub
Private Sub RemoveDuplicates(X)
'Remove Duplicates
Dim i As Long
Dim j As Long
With "ComboBox" & X
For i = 0 To .ListCount + 1 'Getting object required error in this line
For j = .ListCount To (i + 1) Step -1
If .List(j) = .List(i) Then
.RemoveItem j
End If
Next
Next
End With
End Sub
Final Code
Everything works great for removing duplicates.
Public allCBoxes As Collection
Private Sub UserForm_Initialize()
Set allCBoxes = New Collection
allCBoxes.Add ComboBox1
'ComboBox Populate
Dim rngNext As Range
Dim myRange As Range
Dim C As Integer
With Sheets("KEY")
Set rngNext = .Range("B500").End(xlUp).Offset(1, 0)
End With
rngNext.Select
Set myRange = Range("B2", rngNext)
With ComboBox1
For Each rngNext In myRange
If rngNext <> "" Then .AddItem rngNext
Next rngNext
End With
Call RemoveDuplicates(1)
End sub
Private Sub RemoveDuplicates(X)
'Remove Duplicates
Dim i As Long
Dim j As Long
With allCBoxes(X)
For i = 0 To .ListCount + 1
For j = .ListCount -1 To (i + 1) Step -1
If .List(j) = .List(i) Then
.RemoveItem j
End If
Next
Next
End With
End Sub
You get an error because you're passing a string, not an object.
Although intuitively you can think that:
"ComboBox" & X
will become, for example if x = 5,
ComboBox5
you're wrong because you're actually building a string:
"ComboBox5"
And, clearly, if you call a method of a ComboBox object on a String, you will be prompted of "Object Required".
What you want to do is impossible in VBA, where you cannot define variable names at run-time (i.e. ComboBox & X, even if not "as string", will not reference the variable ComboBox5). To reach what you want, I suggest to create a public collection:
Dim allCBoxes As Collection
then to populate it on the main procedure:
Set allCBoxes = New Collection
allCBoxes.Add ComboBox1
allCboxes.Add ComboBox2
'etc.
and finally recovering the "Xth" combobox like this:
With allCBoxes(X)
End With
If you want to reference a control using its string name, use the Controls function.
Such as:
With Controls("Combobox" & X)
Does that resolve the problem?
As mentioned in my comment above, here's a different approach towards solving the underlying problem: needing a combobox without duplicate values. This method uses a Dictionary object.
Let me know if you can adapt it to your needs, and if it works.
Private Sub UserForm_Initialize()
Dim oDictionary As Object
Dim strCellContent As String
Dim rngComboValues As Range
Dim rngCell As Range
Set rngComboValues = Range("A1:A26")
Set oDictionary = CreateObject("Scripting.Dictionary")
For Each rngCell In rngComboValues
strCellContent = rngCell.Value
If Not oDictionary.exists(strCellContent) Then
oDictionary.Add strCellContent, 0
End If
Next rngCell
For Each itm In oDictionary.keys
Me.ComboBox1.AddItem itm
Next itm
Set oDictionary = Nothing
End Sub
I have been developing a UserForm that uses a listbox populated by the A column to delete specific rows based on listbox selection. But when I click the "Apply" button it takes a ridiculously long time until it processed and deleted the rows.
The code for the Apply button is the following, there is almost no other code in the UserForm. Just Me.Hide in the Cancel button.
Private Sub CommandApply_Click()
Dim i As Long
Dim n As Long
Dim col As New Collection
Dim itm As Variant
Dim rng As Range
' First, collect the row numbers corresponding to the selected items
' We work from last to first
n = Me.ListBox1.ListCount
For i = n - 1 To 0 Step -1
If Me.ListBox1.Selected(i) Then
Else
col.Add i + 1
End If
Next i
' Then delete the rows
Set rng = Worksheets("Sheet1").Range("A1:A100")
For Each itm In col
rng.Rows(itm).EntireRow.Delete
Next itm
blnCancel = False
Me.Hide
End Sub
I think you'd be better off collecting the non-selected items into a Range in your loop and then just deleting that:
Private Sub CommandApply_Click()
Dim i As Long
Dim n As Long
Dim col As New Collection
Dim itm As Variant
Dim rng As Range
' First, collect the row numbers corresponding to the selected items
' We work from last to first
n = Me.ListBox1.ListCount
For i = n - 1 To 0 Step -1
If Not Me.ListBox1.Selected(i) Then
If rng Is Nothing then
Set rng = Worksheets("Sheet1").Range("A" & i + 1)
Else
Set rng = Union(rng, Worksheets("Sheet1").Range("A" & i + 1))
End If
End If
Next i
' Then delete the rows
If not rng Is Nothing then rng.Entirerow.delete
blnCancel = False
Me.Hide
End Sub