I would like to count unique entries in a range between blanks. Please look at the attached pic for reference. The first set of data contains 3 unique entries so the highlighted box would 3. The second set of data has 3 unique entries and the highlighted box then would also display 3.
example
#Todd Nielsen
Check the below link which has different solutions for it.
https://support.office.com/en-us/article/Count-unique-values-among-duplicates-7889942d-824e-4469-893c-191d1efde950#bmcount_the_number_of_unique_values__by
Assuming you want to do this in VBA and the range containing the data sets is huge, the question is not as trivial as others which have replied to this post have made it out to be.
The following code requires that you set a reference to the Microsoft Scripting Runtime library. It inserts the number of unique values each time it finds an empty row in the search range (works best if there is only one empty row to separate the different data sets in the range):
Option Explicit
Sub uniquesEntriesInDataSets()
Dim dict As Scripting.Dictionary
Dim i As Long, startAt As Long, uCount As Long
Dim cll As Range, searchRange As Range
Dim val As Variant
' change sheetname and range to relevant parameters
Set searchRange = ThisWorkbook.Sheets("Sheet1").Range("A1:A21")
Set dict = New Dictionary
For Each cll In searchRange
val = cll.Value
If val = vbNullString Then
If dict.Count > 0 Then
cll.Value = dict.Count
dict.RemoveAll
End if
Else
If Not dict.Exists(val) Then dict.Add Key:=val, Item:=i
End If
Next cll
End Sub
Related
This question already has an answer here:
Can we put dictionary items(array) into a Range with a single statement?
(1 answer)
Closed 6 months ago.
At the moment I have a range of names, and I need to create a new column which only contains the unique names.
Sub Unique_Values()
mySheet = Sheets("Sheet1").Range("E9:I20")
With CreateObject("scripting.dictionary")
For Each cell In mySheet
a = .Item(cell)
Next
Range("D2").Value = Join(.keys, vbLf)
End With
End Sub
This code creates a dictionary and returns the list of unique names, but it's one long list (i've just inserted it into D2) but I need it to populate column D with the unique names, one name per cell. I can't quite figure out how to loop through the keys and put them into an individual cell
Please, try the next updated code:
Sub Unique_Values()
Dim MySheet As Worksheet, rng As Range, cell As Range
Set MySheet = Sheets("Sheet1")
Set rng = MySheet.Range("E9:I20")
With CreateObject("scripting.dictionary")
For Each cell In rng.cells
.item(cell.Value) = 1
Next
MySheet.Range("D2").Resize(.count, 1).Value2 = Application.Transpose(.Keys)
End With
End Sub
It is good to declare all necessary variable, naming them in a relevant way.
Then, dict.keys is a 1D array (not having rows) and to place it in a column, it needs to be transposed.
I only tried adapting your code as it is. To make it faster, the iterated range should be placed in an array and then all the array processing will be done in memory, resulting a faster result. Anyhow, for the range you show us (if this is the real one), processing should take less than a second...
In fact, the faster version is easy to be designed, so here it is:
Sub Unique_Values_Array()
Dim MySheet As Worksheet, arr, i As Long, j As Long
Set MySheet = Sheets("Sheet1")
arr = MySheet.Range("E9:I20").Value2
With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
.item(arr(i, j)) = 1
Next j
Next i
MySheet.Range("D2").Resize(.count, 1).Value2 = Application.Transpose(.Keys)
End With
End Sub
It makes sense and speed difference only in case of larger ranges...
If you use a collection you can create a unique list and write to the range. A collection will not let you add the same index key twice, therefore we ignore the error and then resume error checking when done writing.
Sub test()
Dim myNames As New Collection
Dim mySheet As Range
Dim i As Long
Set mySheet = Sheets("Sheet1").Range("E9:I20")
On Error Resume Next
For Each cell In mySheet
myNames.Add cell, cell.Value
Next
On Error GoTo 0
For i = 1 To myNames.Count
Worksheets("Sheet1").Cells(i + 2, 4) = myNames(i)
Next
End Sub
I have an excel file where I load the column headers dynamically from Row 2 across until I hit a null and put all those values into a list box transposed. This part is working as I expect it to.
My question is, how do I use the list box items to select the entire column that the named header exists in?
So in A2 B2 C2 I have the headers called Widget 1, 2, 3 respectively loaded into the listbox. Those load in order in the list box when the userform loads. In the list box, I would like to be able to click Widget 2 and 3 and have those entire columns selected. I don't want it hard coded, as I want it to be a selection as I could select widget 1 and 3 or any random selection as needed.
I could have as many as 50 widgets....so those will all load in the listbox on startup, I need to be able to select any of those values and have them select their corresponding column....
That is where I'm having issues, how to make the multi select happen.
Thanks in advance for any help.
EDITS:
This is the code used on the Private Sub UserForm_Initialize()
'Figure out how many actual columns headers there are and then search for signal names
'Dim Lastcol As String
Dim FoundColumnRangeCalculated As Variant
Dim Lastcol As Variant
Dim FoundColumnRange As Variant
With ActiveSheet
Lastcol = .Cells(2, .Columns.Count).End(xlToLeft).Column
''MsgBox Lastcol
End With
'Convert numerical column location to letter value to use as dynamic range header lookup
Dim NumberToColumn As Variant
Dim SearchColumn
SearchColumn = Lastcol
NumberToColumn = Left(Cells(1, SearchColumn).Address(1, 0), InStr(1, Cells(1, SearchColumn).Address(1, 0), "$") - 1)
'MsgBox NumberToColumn
'Build the actual range from found column headers
FoundColumnRangeCalculated = "A2:" & (NumberToColumn & Lastcol)
'Transfer headers vertically to the list box for user to see
ListBox1.List = Application.WorksheetFunction.Transpose(Range(FoundColumnRangeCalculated))
Imported List Box Transposed on UserForm Load
So now when I click or multi click (not shown in this image, but multi with choose options to be enabled) the item(s), I would like the corresponding column it represents to be selected when each item is clicked.
Columns that the items are drawn from
Since they are built in "order" from left to right, I assume it is a 1:1 match and search and select, but I'm having trouble trying to sort that piece of it out..lots of examples about getting it's data, parsing, etc.....I just simply need a "When listbox items selected, use selection to enable its column".
The columns can't be hard coded for range as the headers could be A:F, A:AA, or A:ZZ.......so it has to be a dynamic matching.
Thanks to those that responded, hopefully this edited post and images satisfy the on hold status.
To select multiple columns may try something like
Option Explicit
Private Sub ListBox1_Change()
Dim Ws As Worksheet, Rng As Range, c As Range, Sel As Range
Dim i As Long, Xval As Variant
Set Ws = ThisWorkbook.Sheets("Sheet1")
Set Rng = Ws.Range(Ws.Cells(2, 1), Ws.Cells(2, Me.ListBox1.ListCount))
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) Then
Xval = Me.ListBox1.List(i)
Set c = Rng.Find(Xval, LookIn:=xlValues)
If Not c Is Nothing Then
If Sel Is Nothing Then
Set Sel = Ws.Columns(c.Column)
Else
Set Sel = Union(Sel, Ws.Columns(c.Column))
End If
End If
End If
Next
If Not Sel Is Nothing Then
Sel.Select
End If
End Sub
In a case if you want to iterate through header's cells. It selects multiple columns for one widget if it's name matched more than once.
Works with ActiveSheet.
Dim result As Range
Dim criteria As String
Dim colcount As Integer
criteria = "widget1" ' Matching value
colcount = 10 ' Header columns count
For i = 1 To colcount
' Loop on 2nd row
If Cells(2, i).Value = criteria Then
' If string matched with a cell's value
If result Is Nothing Then
' if it's first match, set it as result column selection
Set result = Columns(i)
Else
' if it's not first match, add it to result selection
Set result = Union(result, Columns(i))
End If
End If
Next
' Select result seletion
If Not result Is Nothing Then
result.Select
End If
I have 99 columns in one table called tbl_raw. I need to copy 96 of those columns into another table with the same exact header names, but they are rearranged in a different order. What is the most efficient way to do this?
The only way I knew was:
raw_data.Range("tbl_raw[EMPLOYEE]").Copy
processed_data.Range("tbl_processed[EMPLOYEE]").PasteSpecial
However, this would take a lot of code (96 * 2 = 192 lines) and I wasn't sure if there was a more efficient way to do it.
I tried to use https://www.thespreadsheetguru.com/blog/2014/6/20/the-vba-guide-to-listobject-excel-tables, but I couldn't figure out a way to do it with that information either.
Any guidance would be greatly appreciated.
Avoid dealing with copying ListObject columns and use a direct value transfer.
Option Explicit
Sub raw2processed()
Dim lc As Long, mc As Variant, x As Variant
Dim raw_data As Worksheet, processed_data As Worksheet
Dim raw_tbl As ListObject, processed_tbl As ListObject
Set raw_data = Worksheets("raw")
Set processed_data = Worksheets("processed")
Set raw_tbl = raw_data.ListObjects("tbl_raw")
Set processed_tbl = processed_data.ListObjects("tbl_processed")
With processed_tbl
'clear target table
On Error Resume Next
.DataBodyRange.Clear
.Resize .Range.Resize(raw_tbl.ListRows.Count + 1, .ListColumns.Count)
On Error GoTo 0
'loop through target header and collect columns from raw_tbl
For lc = 1 To .ListColumns.Count
Debug.Print .HeaderRowRange(lc)
mc = Application.Match(.HeaderRowRange(lc), raw_tbl.HeaderRowRange, 0)
If Not IsError(mc) Then
x = raw_tbl.ListColumns(mc).DataBodyRange.Value
.ListColumns(lc).DataBodyRange = x
End If
Next lc
End With
End Sub
Here's a basic example of copying over all but some columns from one table to another:
Dim tbl1 As ListObject, tbl2 As ListObject
Dim h As ListColumn
Set tbl1 = ActiveSheet.ListObjects("Table1")
Set tbl2 = ActiveSheet.ListObjects("Table2")
'loop over the headers from the source table
For Each h In tbl1.ListColumns
'is the column name in the "excluded" list?
If IsError(Application.Match(h.Name, Array("col10", "col11"), 0)) Then
'ok to copy...
h.DataBodyRange.Copy tbl2.ListColumns(h.Name).DataBodyRange(1)
End If
Next h
ForEach/For are the magic of working with arrays and collections.
There are ways to make the following code more efficient, but I think that may get in the way of understanding what is happening.
It has been about 6 months or so since I last worked with VBA, but I believe this should work. I suggest stepping through and watching your locals to see what is going on. If there are issues with variable assignments, there might need to be a 'Let' changed to a 'Set'.
Code follows:
'// PROBLEM:
'// Copy data from one list to a second list.
'// Both lists have the same column names and the same number of columns.
'// Copy data based on the column name.
'// Modify to return a custom source-destination association.
Private Function GetColumnTranslations(zLeftColumns As ListColumns, zRightColumns As ListColumns) As Variant
Dim zReturn(,) As Variant
ReDim zReturn(0 To zLeftColumns.Count As Long, 0 To 1 As Long)
Dim zReturnOffset As Long '// Specifies what index we are working at during our ForEach interations.
Dim zLeftVar As Variant
Dim zRightVar As Variant
ForEach zLeftVar in zLeftColumns
'// Go through each 'left' column to Find the first 'right' column that matches the name of the 'left' column.
'// Only the first 'right' column with a matching name will be used. Issue is solved with another ForEach, but beyond forum question's scope.
ForEach zRightVar in zRightColumns
If zLeftVar.Name = zRightVar.Name Then
'// Store the association and exit the nested ForEach.
Let zReturn(zReturnOffset, 0) = zLeftVar.Range.Column '// Source.
Let zReturn(zReturnOffset, 1) = zRightVar.Range.Column '// Destination.
Let zReturnOffset = zReturnOffset + 1
Exit ForEach
End If
Next zRightVar
Next zLeftVar
'// Assign return value.
Let GetColumnTranslations = zReturn
End Function
'// Take each source row and copy the value to a new destination row.
'// New rows are added to the end of the destination list.
Public Sub CopyList(zSourceList As ListObject, zDestinationList As ListObject)
Dim zColumnTranslations As Variant '// Will be 2-dimensional array.
Dim zTranslationVar As Variant '// Will be array of 2 elements.
Let zColumnTranslations = GetColumnTranslations(zSourceList.Columns, zDestinationList.Columns)
Dim zSourceRowVar As Variant '// Will translate to Range.
Dim zDestinationRow As Range
'// Every source row needs copied to a new row in destination.
ForEach zSourceRowVar in zSourceList.Rows
Set zDestinationRow = zDestinationList.Rows.Add.Range
ForEach zTranslationVar in zColumnTranslations
'// Value may copy formula.
Let zDestinationRow(0,zTranslationVar(1)).Value = zSourceRowVar(0,zTranslationVar(0)).Value
Next zTranslationVar
Next zSourceRowVar
End Sub
I have an Excel sheet abc.xlsm" and I have values in "A1" to "A15" in this sheet. I want to copy till 10th row, and then store all the values in an array using VBA.
As mentioned in the comments, please be more specific in your questions: most questions should have at least some bit of code of what you have tried. At any rate this should work, with a couple extra notions:
Sub copy()
'Declaring an array - if you know the data type you can type is as well
Dim varray As Variant
'Declaring other variables - don't need to be separeted, just for clarity
Dim i As Long, iLenghtArray As Integer, rgData As Range, rgTarget As Range
'This is to dimension your array - you have tell VBA the lenght of it, or use REDIM
ilengtharray = 10
'Setting the range reference
Set rgData = Sheet1.Range("$A$1:$J$1")
'Then set the array = to the range you set above
varray = rgData
'Then you can interate over your array like so:
For i = 1 To UBound(varray, 2)
Debug.Print varray(1, i)
Next
'You can also directly past your array into a suitable range
'Setting destination range:
Set rgTarget = Sheet1.Range("$A$2:$J$2")
rgTarget = varray
End Sub
Ideally, I would have a range selected and then I would run the macro and I want the macro to essentially run a loop to go through each row so I can extract information from each row until it reaches the end of the range.
For example, A6:B9 are selected, first I want to focus on A6:B6. As in I want to be able to find the min value of the two cells for instance, using my MinSelected function(stated below) which requires a selected range which would ideally be A6:B6. And I want to do this for each row until the end of the original range.
Function MinSelected(R As Range)
MinSelected = Application.WorksheetFunction.min(R)
End Function
Is there any way to do this??? Please tell me to clarify anything that's unclear. Thanks in advance.
You can loop through rows - but looping through a variant array is more efficient (for many rows)
variant aray
Dim X
Dim lngCnt As Long
X = Range("A6:B9").Value2
For lngCnt = 1 To UBound(X)
Debug.Print Application.Min(Application.Index(X, lngCnt))
Next
range approach
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Range("A6:B9")
For Each rng2 In rng1.Rows
Debug.Print Application.Min(rng2)
Next
Use a For loop, Rows.Count property, Columns.Count
Dim i as long
For i = 1 to Selection.Rows.Count
For j = 1 To Selection.Columns.Count
Cells(i, j).Value ' Use this to access the value of cell in row i and column j