Part 1: A combo box in sheet1 to dynamically list unique values from a column in sheet2 put it in the drop down list
Part 2: Display the related entries of sheet2 in sheet1 based on the combo box selection.
I have done the part 1 in a method call fillCombo and have called it under ComboBox1_DropButtonClick() and part 2 under the method ComboBox1_Change()
First time when i click dropdown arrow of combo box it lists the unique entries and on making the selection in it, the related entries are displayed in sheet1 and everything is fine.
During the next selection of dropdown arrow it goes to ComboBox1_DropButtonclick() method then ComboBox1_change() method, ComboBox1_change() method without the dropdown list appearing and me selecting
So it works correctly only in the first instance.
Can you please correct the error.
Private Sub ComboBox1_Change()
Dim sht2, sht1, a As Long, X As Long, i As Long
Dim Lastrow As Long
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
a = sht2.Cells(Rows.Count, 1).End(xlUp).Row
X = 8
Lastrow = sht1.Range("D" & Rows.Count).End(xlUp).Row
sht1.Range("G8:J" & Lastrow).Clear
For i = 2 To a
If sht2.Cells(i, 3).Value = "Payments" Then
sht2.Cells(i, "C").Resize(1, 4).Copy sht1.Cells(X, "G")
X = X + 1
End If
Next
sht1.Select
sht1.Cells(1, 1).Select
End Sub
Private Sub ComboBox1_DropButtonClick()
Call fillCombo
End Sub
Sub fillCombo()
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Group = 3
firstTime = True
strValue = Sheet1.ComboBox1.Value
'last row
wsLR = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'loop thru rows
For l = 2 To wsLR
If ws2.Cells(l, Group) <> "" And (InStr(uE, "|" & ws2.Cells(l, Group) & "|") = 0) Then
If firstTime = True Then
firstTime = False
uE = "|" & uE & ws2.Cells(l, Group) & "|"
Else
uE = uE & ws2.Cells(l, Group) & "|"
End If
End If
Next l
dropValues = Split(uE, "|")
Sheet1.ComboBox1.Clear
For Each cell In dropValues
If cell <> "" Then
Sheet1.ComboBox1.AddItem cell
End If
Next cell
Sheet1.ComboBox1.Value = strValue
End Sub
Related
Im trying to create a table that pulls data from my raw data if certain conditions are met. The code I currently have does not seem to be working.
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long
Dim tableA As ListObject
Set tableA = Worksheets(Sheet7).ListObject(Preventable)
Set datasheet = Worksheets(Sheet7)
Set datasheet2 = Worksheets("Data")
With datasheet2
nr = Cells(Rows.Count, 1).End(x1up).Row
For r = 1 To nr
If Cells(r, 17) = "Y" Then
Cells(r, 16).Copy Destination:=Sheets("Sheet7").Range("B4")
End If
Next
End With
End Sub
Basically I have several worksheets and need to pull data from one of them to add to this table in another worksheet. My condition is if the Column in the raw data worksheet contains "Y", then pull cell values into the table of the other worksheet. An image below is an example of the data I want to copy and paste over:
As you can see, they are string values separated by "," and can contain duplicates.
I only want to add just the unique entries into the new table; with no repetition of cells. Anyway I could modify this code to suit those conditions?
You could try something like this:
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long, i As Long, nr As Long
Dim tableStartingRow As Long, currenttableitem As Long
Dim stringvalues As Variant
Dim stringseparator As String
Dim valueexists As Boolean
tableStartingRow = 4
stringseparator = ","
Set datasheet = Worksheets("Sheet7")
Set datasheet2 = Worksheets("Data")
With datasheet
currenttableitem = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With datasheet2
nr = .Cells(.Rows.Count, 16).End(xlUp).Row
For r = 1 To nr
If .Cells(r, 17) = "Y" Then
If InStr(.Cells(r, 16), stringseparator) > 0 Then 'If value contains comma
stringvalues = Split(.Cells(r, 16), stringseparator)
For i = LBound(stringvalues) To UBound(stringvalues)
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = Trim(stringvalues(i)) Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = Trim(stringvalues(i))
End If
Next i
Else
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = .Cells(r, 16).Value Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = .Cells(r, 16).Value
End If
End If
End If
Next
End With
End Sub
This code will check each value of the cells and will split the contents by ",". Then compare with the content of the table to see if this value is already in there. In case it is not, it will be added, otherwise omitted.
Also, I notice the use of the Cells inside of a With statement. That was making a reference to the active worksheet. To make reference to the item in the With statement, you need to use .Cells
I hope this will help.
I have some records being displayed in a listbox. I have a 'Hide' button in my userform which when clicked hides the row selected and the row remains in the excel sheet. But if I open the userform again then the data loaded has all the hidden rows. I have created a column 'Active' and assigned it true values. I want to change this value to false when the user selects a row and clicks on hide. I want all the data in the excel sheet to remain and only rows with 'Active' value True will be displayed in the listbox. How do I achieve this?
Here is my code -
Sub Employee_Listbox()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("EMPMaster")
Dim last_row As Long
last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
If last_row = 1 Then last_row = 2
With Me.ListBox2
.ColumnCount = 6
.ColumnWidths = "150,70,100,50,70,0"
.List = sh.Range("A2:F" & last_row).Value '.RowSource = sh.Name & "!A2:F" & last_row
End With
End Sub
Private Sub CommandButton15_Click() '''Hide button
If Me.ListBox2.ListIndex >= 0 Then
Me.ListBox2.RemoveItem Me.ListBox2.ListIndex
End If
End Sub
Try this out. It uses Match to locate the row on the source worksheet and flag that employee as "Inactive".
Option Explicit
Const MASTER_SHEET As String = "EMPMaster"
Const VAL_ACTIVE = "Active"
Const VAL_INACTIVE = "Inactive"
Private Sub UserForm_Activate()
LoadEmployeeList
End Sub
Sub LoadEmployeeList()
Dim sh As Worksheet, rw As Range, i As Long
Set sh = MasterSheet
With Me.ListBox2
.Clear
.ColumnCount = 6
.ColumnWidths = "150,70,100,50,70,0"
End With
For Each rw In sh.Range("A2:F" & sh.Cells(Rows.Count, "A").End(xlUp).Row).Rows
If rw.Columns("G").Value = VAL_ACTIVE Then 'only load "Active" employees
With Me.ListBox2
'add the row
.AddItem (rw.Cells(1).Value)
For i = 2 To rw.Cells.Count
.List(.ListCount - 1, i - 1) = rw.Cells(i).Value
Next i
End With
End If
Next rw
End Sub
Private Sub CommandButton15_Click() '''Hide button
Dim id, m, sh As Worksheet
If Me.ListBox2.ListIndex >= 0 Then
id = Me.ListBox2.List(Me.ListBox2.ListIndex, 0) 'adjust id column to suit
Set sh = MasterSheet
m = Application.Match(id, sh.Columns("A"), 0) 'find the id on the master sheet
If Not IsError(m) Then 'found?
sh.Cells(m, "G").Value = "Inactive" 'mark as inactive
Me.ListBox2.RemoveItem Me.ListBox2.ListIndex 'remove from listbox
Else
'should not happen!
MsgBox "Employee Id '" & id & "' not found on Master sheet!", vbExclamation
End If
End If
End Sub
Function MasterSheet() As Worksheet
Set MasterSheet = ThisWorkbook.Worksheets(MASTER_SHEET)
End Function
**Edit:** Managed to find the solution to it thanks to fellow user #Tin Bum
I'm trying to make 2 Combo Box where the the first one (Cmb1) will show only unique values from Column 1 and then (Cmb2) will show a list of values from Column 2 that are related to Column 1.
Populating the Cmb1 has been successful however the problem lies with populating Cmb2.
Column 1 Column 2
1 a
1 b
1 c
2 d
2 e
The problem lies with populating Cmb2
Private Sub UserForm_Activate()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
With wslk
t1 = .Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).row
On Error Resume Next
For y = 2 To t1
Set c = .Cells(y, 2)
Set t1rng = .Range(.Cells(2, 2), .Cells(y, 2))
x = Application.WorksheetFunction.CountIf(t1rng, c)
If x = 1 Then Cmb1.AddItem c
Next y
On Error GoTo 0
End With
End Sub
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Cmb2.ListIndex = -1
If Cmb1.ListIndex > -1 Then
'Currently I am stuck over here
Cmb2.List =
**Solution:**
Dim i As Integer
Cmb2.Clear
For i = 2 To wslk.Range("B" & Application.Rows.Count).End(xlUp).row
If wslk.Range("B" & i).Value = Cmb1.Value Then
Cmb2.AddItem wslk.Range("C" & i)
End If
End If
End Sub
This the bones of a solution for the Exit Event Code.
It should be Ok for hundreds of rows but may be slow for thousands of rows, also you still have to workout the 2 ranges - I've arbitrarily assigned them to fixed ranges.
On the plus side it should be simple to follow
Dim Rng1 As Range, Rng2 As Range
Dim xCel As Range, List2 As String
Rng1 = Range("A10:A20") ' whatever Range covers your Col1 Data
Rng2 = Range("B10:B20") ' whatever Range covers your Col2 Data
List2 = ""
For Each xCel In Rng2.Cells
If xCel.Offset(0, -1).Value = Combobox1.Value Then
' Add this Value to a String using VbCrLf as a Separator
List2 = IIf(List2 = "", "", List2 & vbCrLf) & CStr(xCel.Value)
End If
Next xCel
' Split the String into an Array of Values for ComboBox2
ComboBox2.List = Split(List2, vbCrLf)
It also relies on NOT HAVING CHR(13) & CHR(10) (VbCrLF) in your data
You could use a Dictionary to get your unique values and also populate this on your Initialize Sub. Making this a Public variable in the scope of the Userform will allow you to then use it later on the Change event as well to get your list values
Option Explicit
Private Uniques As Object
Private Sub UserForm_Initialize()
Dim c As Range, InputRng As Range
Dim tmp As Variant
Dim k As String
Set Uniques = CreateObject("Scripting.Dictionary")
With Worksheets("w1")
Set InputRng = .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 2))
For Each c In InputRng
k = c.Value2
If Uniques.exists(k) Then
tmp = Uniques(k)
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(UBound(tmp)) = c.Offset(0, 1).Value2
Uniques(k) = tmp
Else
ReDim tmp(0)
tmp(0) = c.Offset(0, 1).Value2
Uniques.Add Key:=k, Item:=tmp
End If
Next c
Cmb1.List = Uniques.keys
End With
End Sub
Private Sub Cmb1_Change()
Cmb2.ListIndex = -1
If Cmb1.ListIndex > -1 Then
Cmb2.List = Uniques(Cmb1.Value)
End If
End Sub
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Dim i As Integer
Cmb2.Clear
For i = 2 To wslk.Range("B" & Application.Rows.Count).End(xlUp).row
If wslk.Range("B" & i).Value = Cmb1.Value Then
Cmb2.AddItem wslk.Range("C" & i)
End If
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 need your help. It seems what I have written in code does not accomplish what I am trying to do here.
The objective would be to have 2 userform combo boxes one for the (floor) values which are manually added once [3,4,5] and the other combo boxes (offices) in which values are dynamically added based on the selection made in the floor selection box.
Let's say for example that if I chose the value [3] in my floor combo box that the office combo box would contain the following values:
A-01
A-02
A-03
A-04
A-05
A-06
A-07
A-08
I thought this code would work but it doesn't:
'Cells(row, col)
Private Sub floor_Change()
lRow = Sheets("Office Spaces").UsedRange.Rows.Count
With Sheets("Office Spaces")
For i = 2 To lRow
If .Cells(i, 1).Value = UserForm1.floor.Value Then
UserForm1.office.AddItem .Cells(i, 2).Value
End If
Next i
End With
End Sub
Here's what the data looks in my excel sheet:
'Cells(row, col)
Private Sub floor56_Change()
UserForm1.office.Clear
Dim sh
Dim rw
Set sh = Sheets("Office Spaces")
For Each rw In sh.Rows
If sh.Cells(rw.row, 1).Text = UserForm1.floor.Value Then
UserForm1.office.AddItem (sh.Cells(rw.row, 2).Value)
End If
Next rw
End Sub
or
Private Sub floor_Change()
If UserForm1.floor.Value <> "" Then
UserForm1.office.Clear
Dim ws
Set ws = ThisWorkbook.Worksheets("Office Spaces")
Dim rng
Set rng = ws.Range("A:A")
For Each cell In rng
If cell.Text = UserForm1.floor.Value Then
UserForm1.office.AddItem (cell.Offset(0, 1).Value)
End If
Next cell
End If
End Sub