Remove value from range populating my listbox - vba

Hello everyone I have two listboxes. The first listbox contains all the items to choose from. After selecting an item, a user clicks on an 'ADD' command button to copy that value onto the range of the second listbox. I believe most of you have seen similar add/remove listboxes.
Both listboxes were created by inserting controls and they are populated by an input range of items on a hidden worksheet.
Here is my problem: adding names is works fine, however the 'remove' procedure I created seems to take a long time to complete since the list of items can be more than 200 items.
I use the following code to match a selected listbox value with the input range value and then it clears the contents of the cell in the input range:
Sub remove()
Dim r As Long
Dim al As ListBox
Dim d As Range
Dim dd As Range
Dim allpick As Worksheet
Set al = Worksheets("LISTBOX").ListBoxes("listselected")
Set allpick = Worksheets("columns")
Set dd = allpick.Range("selectedNAMES")
With al
For r = 1 To .ListCount
If .selected(r) Then
For Each d In dd
If d.Value = .List(r) Then
d.ClearContents
End If
Next d
End If
Next r
End With
End Sub
Is there an alternative code or structure I could use so that it doesn't take so long to complete?

I used the find function stated by commenters and wrote the code below. It is much faster and is exactly what I wanted. However, I didn't know what to put after "IF CELL IS NOTHING THEN" so i just used calculate. Any suggestions?
Dim r As Long
Dim al As ListBox
Dim strNAME As String
Dim names As Worksheet
Set names = Worksheets("names")
Set al = Worksheets("HOME").ListBoxes("selectednames")
With al
For r = 1 To .ListCount
If .Selected(r) Then
strNAME = .List(r)
Set cell = names.Range("currentnames").Find(What:=strNAME)
If cell Is Nothing Then
Calculate
Else: cell.ClearContents
End If
End If
Next r
End With

Related

How to correctly set the list property? (Error 381)

I have created a listbox which can be filtered according to keyword in textbox. It works if I do it normally. However, it stopped working when the list is a dependent source. (The listbox value is like INDIRECT() of F1 and I'm trying to filter that INDIRECT list)
I have 3 lists as shown in the image (A, B, D). D is a list of A without duplicates. the listbox("lbxCustomers") in Userform2 uses a dependent rowsource according to word selected at Cell F2. [It works until here]
The values in the listbox will be filtered according to keyword in textbox("tbxFind"). I'm getting an error at this line ".List = vaCustNames". I tried to change it into a normal range (sheet1.range(...)) and it works but the list is not a dependent list of F1.
image
Private Sub UserForm_Initialize()
Me.lbxCustomers.RowSource = Range("F2").Value
End Sub
Private Sub tbxFind_Change()
Dim i As Long
Dim sCrit As String
Dim vaCustNames As Variant
vaCustNames = Range("F2").Value
Debug.Print Range("F2").Value
sCrit = "*" & UCase(Me.tbxFind.Text) & "*"
With Me.lbxCustomers
.RowSource = ""
'Start with a fresh list
.List = vaCustNames
'.List = Sheet1.Range("B2:B13").Value 'tested with range and worked
For i = .ListCount - 1 To 0 Step -1
'Remove the line if it doesn’t match
If Not UCase(.List(i)) Like sCrit Then
.RemoveItem i
End If
Next i
End With
End Sub

Filtering a ListBox to only include unique values in Excel

i have a simple Excel/VBA problem:
What i want to create is a (single-select) ListBox where I want to show unique values of Data i have on a different worksheet.
So far I have a ListBox like this:
And a named selection of the data i want to show:
I used a formula like this and used that as the input for the ListBox.
The formula: =BEREICH.VERSCHIEBEN(TopicData!$C$1;1;0;ANZAHL2(TopicData!$C:$C)-1;1)
Now my question is: How can i get the ListBox to show only unique values? I am familiar with vba, so a solution including this would be totally fine. In fact I already tried to remove duplicate entries in vba, whenever there is a change to the ListBox, but for some reason nothing seems to work.
Here is my vba script where I tried to solve this:
unfortunatley I always get a "Error 400" when I trie to call RemoveItem on the ListBox.
' ...
' filter listbox content so only unique values remain
Dim i As Integer
' find duplicates
Dim inList As New Collection
Dim indexesToRemove As New Collection
For i = availableTopicsListBox.ListCount - 1 To 1 Step -1
If CollectionContains(inList, availableTopicsListBox.List(i)) Then
' if it is already in the list, remove it
indexesToRemove.Add i
Else
inList.Add availableTopicsListBox.List(i)
End If
Next i
' remove duplicates
Dim j As Integer
For j = indexesToRemove.count To 1 Step -1
availableTopicsListBox.RemoveItem (indexesToRemove(j))
Next j
'...
The code below will use the Dictionary to store only unique values from column C (in "TopicData" worksheet), and then populate availableTopicsListBox listbox with only the unique values inside the Dictionary.
Code
Option Explicit
Private Sub UserForm_Activate()
Dim Dict As Object
Dim Key As Variant
Dim LastRow As Long
Dim C As Range
With Sheets("TopicData") '<-- I think this is your sheet's name
' find last row with data in column "C"
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set Dict = CreateObject("Scripting.Dictionary")
For Each C In .Range("C1:C" & LastRow)
If C.Value <> "" Then ' <-- skip empty cells
If Not Dict.exists(C.Value) Then
Dict.Add C.Value, 1
End If
End If
Next C
End With
' loop through all unique keys, and add them to the listbox
For Each Key In Dict.keys
availableTopicsListBox.AddItem Key
Next Key
End Sub

Excel VBA - Return selected element in slicer

I have a slicer called 'Slicer_HeaderTitle'. I simply need to be able to dim a variable in VBA with the value of the selected element. I'll only have one element selected at a time.
I've had a lot of problems with selecting and de-selecting elements from my slicer dynamically via VBA, since my pivot table is connected to an external data-source. I don't know if this is relevant for this exact example, but this table is connected to the same external data-source.
I used to have a single line of code, which could return this value, but all i could find now requires you loop through each element in the slicer and check if it's selected or not. I hope to avoid this, since I only have 1 selected element at a time.
' This is what I'm trying to achieve.
Dim sValue as String
sValue = ActiveWorkbook.SlicerCaches("Slicer_HeaderTitle").VisibleSlicerItems.Value
msgbox(sValue)
'Returns: "Uge 14 - 2016 (3. Apr - 9. Apr)"
Current Status:
This is what i did:
Public Function GetSelectedSlicerItems(SlicerName As String) As String
Dim SL As SlicerCacheLevel
Dim sI As SlicerItem
Set SL = ActiveWorkbook.SlicerCaches(SlicerName).SlicerCacheLevels(1)
For Each sI In SL.SlicerItems
If sI.Selected = True Then
GetSelectedSlicerItems = (sI.Value)
End If
Next
End Function
Dim sValue As String
sValue = GetSelectedSlicerItems("Slicer_HeaderTitle")
Thanks to Doktor OSwaldo for helping me a lot!
Ok to find the error, we will take a step back, delete my function and try Looping through the items:
Dim sC As SlicerCache
Dim SL As SlicerCacheLevel
Dim sI As SlicerItem
Set sC = ActiveWorkbook.SlicerCaches("Slicer_Dates_Hie")
Set SL = sC.SlicerCacheLevels(1)
For Each sI In SL.SlicerItems
sC.VisibleSlicerItemsList = Array(sI.Name)
Next
I would like to put in my two cents. The set of visible slicer items may be shrunk by both independent actions:
User selection of items in slicer A. To capture those items, use .Selected method.
Selection of items in slicer B which in consequence shrinks the list of slicer A items. To capture those items, use .HasData method.
Note that you may see only say two items of Slicer_Products (apples, bananas) because some other slicer Slicer_Product_Type has active filter on fruits. The method sI.Selected would still return the whole list of products apples, bananas, carrots...
If you want both limitations to be in place then make intersection of both sets. I have modified TobiasKnudsen code (excellent answer!) to return the list of items shrunk by both above limitations. If sI.Selected = True And sI.HasData = True Then is the key line in this code.
Option Explicit
Sub TestExample()
Dim MyArr() As Variant
MyArr = ArrayListOfSelectedAndVisibleSlicerItems("Slicer_A")
'now variable MyArr keeps all items in an array
End Sub
Public Function ArrayListOfSelectedAndVisibleSlicerItems(MySlicerName As String) As Variant
'This function returns an array of the limited set of items in Slicer A
'Limitation is due to both:
'(1) direct selection of items by user in slicer A
'(2) selection of items in slicer B which in consequence limits the number of items in slicer A
Dim ShortList() As Variant
Dim i As Integer: i = 0 'for iterate
Dim sC As SlicerCache
Dim sI As SlicerItem 'for iterate
Set sC = ThisWorkbook.Application.ActiveWorkbook.SlicerCaches(MySlicerName)
For Each sI In sC.SlicerItems
If sI.Selected = True And sI.HasData = True Then 'Here is the condition!!!
'Debug.Print sI.Name
ReDim Preserve ShortList(i)
ShortList(i) = sI.Value
i = i + 1
End If
Next sI
ArrayListOfSelectedAndVisibleSlicerItems = ShortList
End Function
Sub Demo()
Dim i As Integer
With ActiveWorkbook.SlicerCaches("Slicer_Country")
For i = 1 To .SlicerItems.Count
If .SlicerItems(i).Selected Then
Sheets("Pivot Sheet").Range("I" & i) = SlicerSelections & " " & .SlicerItems(i).Value
End If
Next i
End With
End sub
This is how I managed to identify the selected element on a slicer.
The answer by TobiasKnudsen above did not work for me as I got an error stating the data source needed to be an OLAP source.
My data is an excel table and this is the code that worked:
Dim val as Boolean
val = ThisWorkbook.SlicerCaches("Slicer_MYSLICER").VisibleSlicerItems.Item("CS").HasData
In my case, the slicer had only 3 items so I repeated the line above with a different string in item()
So, where val was true, that was the item that was currently selected.

Delete entire row when a value exist (With sheets) [duplicate]

I have 2 sheets: sheet1 and sheet2. I have a value in cell A3 (sheet1) which is not constant. And many files in sheets2.
What I would like to do, is when the value in cell A3 (Sheet1) is the same as the value in the column A (Sheet2), it will delete the entire row where is find this value (Sheet2).
This is my attempt. It doesn't work: no rows are deleted.
If Worksheets("Sheet1").Range("A3").Text = Worksheets("Sheet2").Range("A:A").Text Then
Dim f As String
f = Worksheets("Sheet1").Range("A3")
Set c = Worksheets("Sheet2").Range("A:A").Find(f)
Worksheets("Sheet2").Range(c.Address()).EntireRow.Delete
End If
My guess is that you're not finding anything with the .Find(). Since you're not checking it for is Nothing you don't know. Also, .Find() retains all the search parameters set from the last time you did a search - either via code or by hand in your spreadsheet. While only the What parameter is required, it's always worth setting the most critical parameters (noted below) for it, you may want to set them all to ensure you know exactly how you're searching.
Dim f As String
If Worksheets("Sheet1").Range("A3").Text = Worksheets("Sheet2").Range("A:A").Text Then
f = Worksheets("Sheet1").Range("A3")
Set c = Worksheets("Sheet2").Range("A:A").Find(What:=f, Match:=[Part|Whole], _
LookIn:=[Formula|value])
if not c is Nothing then
Worksheets("Sheet2").Range(c.Address()).EntireRow.Delete
else
MsgBox("Nothing found")
End If
End If
Go look at the MS docs to see what all the parameters and their enumerations are.
Sub Test()
Dim ws As Worksheet
For x = 1 To Rows.Count
If ThisWorkbook.Sheets("Sheet2").Cells(x, 1).Value = ThisWorkbook.Sheets("Sheet1").Cells(3, 1).Value Then ThisWorkbook.Sheets("Sheet2").Cells(x, 1).EntireRow.Delete
Next x
End Sub

lookup a number and increment value in another cell within same row

I would like to create a macro in excel that lets me increment the counts of a part whenever I press a command button.
Currently, my concept is to use vlookup to get the existing counts for that part using the following. However, it does not increment the actual counts value in the cell, which is what I want. I suspect it's cos vlookup is only used to return a value within the cell, but the cell is not activated in the process for actual increment. Can someone please advise how I can correct it? I'm still new to vba. Thanks!!! :)
E.g. Vlookup finds C1value in Cell A5 of Sheets("Location"). It will automatically increment the value in Cell C5 by 1.
Sub FindAddTools()
Dim C1Qnty As Double
C1value = Sheets("Issue").Range("D11")
Sheets("Location").Activate
C1Qnty = WorksheetFunction.VLookup(C1value, Range("A:D"), 3, False)
C1Qnty = C1Qnty + 1
End Sub
ADD ON: an add-on to my original question. I was wondering if it is possible to do the same for an entire range?
E.g. C1value is now a range of Sheets("Issue").Range("D11:D20"). I want to find all values within this range in Sheets("Location") and increment their corresponding counts in Column C.
Is there a way to do this without repeating the same procedure for all cells of the range?
Thanks! :)
Here's my shot at it. If the value isn't matched nothing happens:
Sub FindAddTools()
Dim RangeToMatch As Excel.Range
Dim cell As Excel.Range
Dim C1Value As Variant
Dim C1Row As Variant
Set RangeToMatch = Sheets("Issue").Range("D2:D11")
For Each cell In RangeToMatch
C1Value = cell.Value
With Sheets("Location")
C1Row = Application.Match(C1Value, .Range("A:A"), 0)
If Not IsError(C1Row) Then
.Range("C" & C1Row).Value = .Range("C" & C1Row).Value + 1
End If
End With
Next cell
End Sub
I edited it so that it cycles through a range of cells to match. That range is set to D2:D11 above.
Based on your comments, I think this should do it.
NB: you don't have to Activate worksheets to perform the functions referencing their cells/ranges.
Sub FindAddTools()
Dim shIssue as WOrksheet: Set shIssue = Sheets("Issue")
Dim shLoc as Worksheet: Set shLoc = Sheets("Location")
Dim allC1Values as Range
Dim C1Value as Variant
Dim C1Qnty As Double
Dim foundRow as Long
Set allC1Values = shIssue.Range("D11:D100") '## Modify as needed.
For each C1Value in allC1Values.Cells
C1Qnty = WorksheetFunction.VLookup(C1value, shLoc.Range("A:D"), 3, False)
C1Qnty = C1Qnty + 1
foundRow = WorksheetFunction.Match(c1Value,shLoc.Range("A:A"),False)
shLoc.Range("C" & foundRow).Value = CqQnty
Next
End Sub
Be careful with this. You're immediately writing to the same cell you just "found" with the VLOOKUP function, so, obviously if you run this macro again, you're going to increment it again. But, this may be the desired functionality, if so, no problem.
NOTE: There is no error trapping for if C1Value is not found in the VLOOKUP or MATCH functions.