Related
I have data in Sheet2 as like below.
Actual Data
Then I manually apply filer to those data which looks like...
Filtered Data
I have a user form (UserForm1) and a list box (ListBox1) in the form. Also have a command button cmdFilteredData. So, I want to fill the listbox with filtered data only. I make below codes but it gives Type mismatch error.
Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
Set FilteredRange = Sheet2.Range("A1:C5").Rows.SpecialCells(xlCellTypeVisible)
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.RowSource = FilteredRange
End With
End Sub
Any help is hearty appreciated.
Since you are trying to populate the ListBox1 with values from filtered range, you have blank rows in the middle, this "messes" up the ListBox.
Instead, you can copy>>Paste the value to columns on the right (or another worksheet), use an array to populate these values, and then populate the ListBox1 with the array.
Code
Private Sub cmdFilteredData_Click()
Dim FilteredRange As Range
Dim myArr As Variant
Set FilteredRange = ThisWorkbook.Sheets("Sheet8").Range("A1:C5").SpecialCells(xlCellTypeVisible)
' copy filtered range to the columns on the right (if you want, you can add a "Dummy" sheet), to have the range continous
FilteredRange.Copy Range("Z1")
' populae the array with new range values (without blank rows in the middle)
myArr = Range("Z1").CurrentRegion
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.List = (myArr)
End With
End Sub
Alternative Function to - unreliable - SpecialCells(xlCellTypeVisible)
This answer intends to complete Shai Rado's appreciated solution, not to correct it.
Testing the above solution, however showed that using SpecialCells(xlCellTypeVisible) and/or reference to CurrentRegion might result in problems (even within OP's small range).
A possible work around function (esp. for udfs) is presented at SpecialCells(xlCellTypeVisible) not working in UDF.
Private Function VisibleCells(rng As Range) As Range
' Site: https://stackoverflow.com/questions/43234354/specialcellsxlcelltypevisible-not-working-in-udf
' Note: as proposed by CalumDA
Dim r As Range
For Each r In rng
If r.EntireRow.Hidden = False Then
If VisibleCells Is Nothing Then
Set VisibleCells = r
Else
Set VisibleCells = Union(VisibleCells, r)
End If
End If
Next r
End Function
Shai Rado's solution slightly modified (cf. above notes)
In any case the target range has to be cleared before copying and then better referenced without CurrentRegion, so that you get the wanted items only. These changes worked for me.
Option Explicit
Private Sub cmdFilteredData_Click()
Dim ws As Worksheet
Dim sRng As String
Dim FilteredRange As Range
Dim myArr As Variant
Dim n As Long
Set ws = ThisWorkbook.Worksheets("Filtered")
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' get last row
sRng = "A1:C" & n
' Set FilteredRange = ws.Range(sRng).SpecialCells(xlCellTypeVisible) ' << not reliable
Set FilteredRange = VisibleCells(ws.Range(sRng)) ' <<<< possible ALTERNATIVE
' clear target range in order to allow correct array fillings later !
ws.Range("Z:AAB").Value = ""
' copy filtered range to the columns on the right
FilteredRange.Copy ws.Range("Z1")
' populate the array with new range values (without blank rows in the middle)
' myArr = ws.Range("Z1").CurrentRegion ' sometimes unreliable, too
myArr = ws.Range("Z1:AAB" & ws.Range("Z" & ws.Rows.Count).End(xlUp).Row) ' <<< better than CurrentRegion
With Me.ListBox1
.ColumnCount = 3
.MultiSelect = fmMultiSelectExtended
.List = (myArr)
End With
End Sub
Links mentioned in cited post:
Microsoft - udf not working
ExcelForum - xlCelltypeVisible not working
MrExcel - SpecialCells not working
I was searching a lot for that but I couldn't fine any elegant solution for doing it without pasting data in the sheet. So I create my own function to convert visible cells of range into an array.
Maybe it's not the smartest way, but works just fine an quite fast.
Function createArrFromRng(rng As Range)
Dim sCellValues() As Variant
Dim col, row, colCount, RowCount As Integer
col = 0
row = 0
colCount = 0
RowCount = 0
On Error GoTo theEnd
Set rng = rng.SpecialCells(xlCellTypeVisible)
'get the columns and rows size
For Each cell In rng
If col < cell.Column Then
colCount = colCount + 1
Else
colCount = 1
End If
col = cell.Column
If row < cell.row Then
RowCount = RowCount + 1
End If
row = cell.row
Next cell
'set the array size
ReDim Preserve sCellValues(RowCount - 1, colCount - 1)
col = 0
row = 0
colCount = 0
RowCount = 0
'get the values and add to the array
For Each cell In rng
If col < cell.Column Then
colCount = colCount + 1
Else
colCount = 1
End If
col = cell.Column
'Debug.Print colCount
If row < cell.row Then
RowCount = RowCount + 1
End If
row = cell.row
sCellValues(RowCount - 1, colCount - 1) = cell.value
Next cell
theEnd:
createArrFromRng = sCellValues
End Function
I am using a Listbox which contains the name of folders. I need to select the names from listbox (one at a time, to maintain the order of selection) and add it to the excel column A1, such that each time adding to the next empty cell of column A. I am very new to vb and need help. Below are the approaches i tried.
Approach 1)
Sub AddRecord_Click()
With Sheet1.ListBox1
For intIndex = 0 To .ListCount - 1
With ActiveSheet
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
End With
If .Selected(intIndex) Then
Sheet1.Cells(LastRow, "A") = Sheet1.ListBox1.Value
NextRow = LastRow + 1
End If
Next
End With
End Sub
Approach 2)
Sub AddRecord_Click()
intRecord = (CInt(Range("A1").End(xlDown).Row) + 1)
Sheet1.Cells(intRecord, "A") = Sheet1.ListBox1.Value
intRecord = intRecord + 1
End Sub
Try this may be helpful to u
Sub ListBox7_Change()
Dim i As Long
With ActiveSheet.ListBoxes("List Box 7")
For i = 1 To .ListCount
If .Selected(i) Then
Range("A" & Rows.count).End(xlUp).offset(1).Value = .List(i)
End If
Next i
End With
End Sub
First you get last used row from the excel sheet and finally increment that last row and insert next column value to the excel.
Dim last as Excel.Range = xlWorkSheet.Cells.SpecialCells
(Excel.XlCellType.xlcellTypeLastCell,Type.Missing)
dim lastUsedRow As Integer = last.Row
lastUsedRow += 1
xlWorksheet.RangeA("A"+ lastUserRow).value = ListBox1.Value
So I am trying to create a combined list from two separate columns by omitting the duplicate items. I have searched and found a formula that combines the list this way by going through one column at a time.
But I want to combine the columns like this:
where it goes through each row first.
Is there a formula or VBA code that does that? Thank you.
EDIT: This is just a way to show my request. The color was added to show how the combined list is sorted, it is not part of the request. The actual lists are each about 500 rows long consisting of 9+ digit ID numbers.
This will put the unique words in the order you want.
Sub foo()
Dim rng As Range
Dim ws As Worksheet
Dim i&, j&, t&
Dim dict As Object
Dim iArr() As Variant
Dim oarr() As Variant
Dim itm As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
With ws
Set rng = .Range("A:B").Find("*", .Range("A1"), , , , xlPrevious)
If Not rng Is Nothing Then
iArr = .Range(.Cells(2, 1), .Cells(rng.Row, 2)).Value
For i = LBound(iArr, 1) To UBound(iArr, 1)
For j = LBound(iArr, 2) To UBound(iArr, 2)
If iArr(i, j) <> "" Then
On Error Resume Next
dict.Add iArr(i, j), iArr(i, j)
On Error GoTo 0
End If
Next j
Next i
End If
'If your dataset is not that large <30,000, then you can use it directly with transpose
.Range("C2").Resize(dict.Count) = Application.Transpose(dict.items)
'If your data is large then you will want to put it in a one dimensional array first
'just uncomment the below and comment the one line above
' ReDim oarr(1 To dict.Count, 1 To 1)
' t = 1
' For Each itm In dict.keys
' oarr(t, 1) = dict(itm)
' t = t + 1
' Next itm
' Range("C2").Resize(dict.Count) = oarr
End With
End Sub
UDF solution. Using your provided sample data, put this formula in cell I2 and copy down =UnqList(ROW(I1),$G$2:$H$6) or =UnqList(ROW(I1),$G$2:$G$6,$H$2:$H$6) (it can be either because the two or more lists might not be next to each other and the UDF accounts for that)
Public Function UnqList(ByVal lIndex As Long, ParamArray rLists() As Variant) As Variant
Dim i As Long, j As Long
Dim vList As Variant
Dim cUnq As Collection
Dim lMaxRow As Long, lMaxCol As Long
If lIndex <= 0 Then
UnqList = CVErr(xlErrRef)
Exit Function
End If
For Each vList In rLists
If TypeName(vList) <> "Range" Then
UnqList = CVErr(xlErrRef)
Exit Function
Else
If vList.Rows.Count > lMaxRow Then lMaxRow = vList.Rows.Count
If vList.Columns.Count > lMaxCol Then lMaxCol = vList.Columns.Count
End If
Next vList
Set cUnq = New Collection
For i = 1 To lMaxRow
For j = 1 To lMaxCol
For Each vList In rLists
If i <= vList.Rows.Count And j <= vList.Columns.Count Then
On Error Resume Next
cUnq.Add vList.Cells(i, j).Value, CStr(vList.Cells(i, j).Value)
On Error GoTo 0
If lIndex = cUnq.Count Then
UnqList = cUnq(cUnq.Count)
Set cUnq = Nothing
Exit Function
End If
End If
Next vList
Next j
Next i
UnqList = CVErr(xlErrRef)
Set cUnq = Nothing
End Function
You can use my Duplicate Master addin available via my profile.
Advantages are that the addin provides options to
ignore capitilisation
ignore whitespace
run RegExp replacements (advanced)
further options for deletinf, highlighting, selecting duplicates etc
I am trying to get Excel data, which was mapped using a grid/matrix mapping into a de-normalized for so that i can enter the data into a database.
How do you copy data in a grid from one excel sheet to the other as follow illustrated below.
I was trying something like this... but as you can see, i am far off!
Sub NormaliseList(mySelection As Range)
Dim cell As Range
Dim i As Long
i = 1
For Each cell In mySelection
If cell <> "" Then
Sheets(2).Range("A" & i).Value = cell(cell.Row, 1).Value
Sheets(2).Range("B" & i).Value = cell.Value
Sheets(2).Range("C" & i).Value = cell(1, cell.Column).Value
i = i + 1
Next cell
End Sub
For Reference. I Updated my code..
Simply add the code, assign macro shortcut to the function
Select the range that contains the intersection data (not the row and column data)
Run macro (Beware, sheet 2 will have data added in normalised form)
If there are multiple headings that are needed i figured i would consolidate into one column then perform a "text to columns" after processing.
Sub NormaliseList()
' to run - assign macro shortcut to sub - Select Intersection data (not row and column headings and run)
Dim Rowname, ColumnName, IntValue As String
Dim x, cntr As Integer
Dim test As Boolean
cntr = 0
For x = 1 To Selection.Count
If Selection(x).Value <> "" Then
cntr = cntr + 1
Rowname = ActiveSheet.Cells(Selection.Cells(x).Row, Selection.Column - 1)
ColumnName = ActiveSheet.Cells(Selection.Row - 1, Selection.Cells(x).Column)
IntValue = Selection(x).Value
test = addrecord(Rowname, ColumnName, IntValue, cntr)
End If
Next x
End Sub
Function addrecord(vA, vB, vC As String, rec As Integer) As Boolean
'Make sure that you have a worksheet called "Sheet2"
Sheets("Sheet2").Cells(rec, 1) = vA
Sheets("Sheet2").Cells(rec, 2) = vB
Sheets("Sheet2").Cells(rec, 3) = vC
End Function
I've got two posts, with usable code and downloadable workbook, on doing this in Excel/VBA on my blog:
http://yoursumbuddy.com/data-normalizer
http://yoursumbuddy.com/data-normalizer-the-sql/
Here's the code:
'Arguments
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
' whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.
Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _
NormalizedColHeader As String, DataColHeader As String, _
Optional NewWorkbook As Boolean = False)
Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range
Dim NormalizedRowsCount As Long
Dim RepeatingList() As String
Dim NormalizedList() As Variant
Dim ListIndex As Long, i As Long, j As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
With List
'If the normalized list won't fit, you must quit.
If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
MsgBox "The normalized list will be too many rows.", _
vbExclamation + vbOKOnly, "Sorry"
Exit Sub
End If
'You have the range to be normalized and the count of leftmost rows to be repeated.
'This section uses those arguments to set the two ranges to parse
'and the two corresponding arrays to fill
FirstNormalizingCol = RepeatingColsCount + 1
NormalizingColsCount = .Columns.Count - RepeatingColsCount
Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)
Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)
NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count
ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)
ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)
End With
'Fill in every i elements of the repeating array with the repeating row labels.
For i = 1 To NormalizedRowsCount Step NormalizingColsCount
ListIndex = ListIndex + 1
For j = 1 To RepeatingColsCount
RepeatingList(i, j) = List.Cells(ListIndex, j).Value2
Next j
Next i
'We stepped over most rows above, so fill in other repeating array elements.
For i = 1 To NormalizedRowsCount
For j = 1 To RepeatingColsCount
If RepeatingList(i, j) = "" Then
RepeatingList(i, j) = RepeatingList(i - 1, j)
End If
Next j
Next i
'Fill in each element of the first dimension of the normalizing array
'with the former column header (which is now another row label) and the data.
With ColsToNormalize
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)
NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)
Next j
Next i
End With
'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Worksheets(1)
Else
Set wbSource = List.Parent.Parent
With wbSource.Worksheets
Set wsTarget = .Add(after:=.Item(.Count))
End With
End If
With wsTarget
'Put the data from the two arrays in the new worksheet.
.Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList
.Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList
'At this point there will be repeated header rows, so delete all but one.
.Range("1:" & NormalizingColsCount - 1).EntireRow.Delete
'Add the headers for the new label column and the data column.
.Cells(1, FirstNormalizingCol).Value = NormalizedColHeader
.Cells(1, FirstNormalizingCol + 1).Value = DataColHeader
End With
End Sub
You’d call it like this:
Sub TestIt()
NormalizeList ActiveSheet.UsedRange, 1, "Name", "Count", False
End Sub
Can anyone give me VBA code that will take a range (row or column) from an Excel sheet and populate a list/array with the unique values,
i.e.:
table
table
chair
table
stool
stool
stool
chair
when the macro runs would create an array some thing like:
fur[0]=table
fur[1]=chair
fur[2]=stool
Sub GetUniqueAndCount()
Dim d As Object, c As Range, k, tmp As String
Set d = CreateObject("scripting.dictionary")
For Each c In Selection
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
Debug.Print k, d(k)
Next k
End Sub
In this situation I always use code like this (just make sure delimeter you've chosen is not a part of search range)
Dim tmp As String
Dim arr() As String
If Not Selection Is Nothing Then
For Each cell In Selection
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
Next cell
End If
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
Combining the Dictionary approach from Tim with the variant array from Jean_Francois below.
The array you want is in objDict.keys
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub
This is the old-school way of doing it.
It will execute faster than looping through cells (e.g. For Each cell In Selection) and will be reliable no matter what, as long you have a rectangular selection (i.e. not Ctrl-selecting a bunch of random cells).
Sub FindUnique()
Dim varIn As Variant
Dim varUnique As Variant
Dim iInCol As Long
Dim iInRow As Long
Dim iUnique As Long
Dim nUnique As Long
Dim isUnique As Boolean
varIn = Selection
ReDim varUnique(1 To UBound(varIn, 1) * UBound(varIn, 2))
nUnique = 0
For iInRow = LBound(varIn, 1) To UBound(varIn, 1)
For iInCol = LBound(varIn, 2) To UBound(varIn, 2)
isUnique = True
For iUnique = 1 To nUnique
If varIn(iInRow, iInCol) = varUnique(iUnique) Then
isUnique = False
Exit For
End If
Next iUnique
If isUnique = True Then
nUnique = nUnique + 1
varUnique(nUnique) = varIn(iInRow, iInCol)
End If
Next iInCol
Next iInRow
'// varUnique now contains only the unique values.
'// Trim off the empty elements:
ReDim Preserve varUnique(1 To nUnique)
End Sub
Profiting from the MS Excel 365 function UNIQUE()
In order to enrich the valid solutions above:
Sub ExampleCall()
Dim rng As Range: Set rng = Sheet1.Range("A2:A11") ' << change to your sheet's Code(Name)
Dim a: a = rng
a = getUniques(a)
arrInfo a
End Sub
Function getUniques(a, Optional ZeroBased As Boolean = True)
Dim tmp: tmp = Application.Transpose(WorksheetFunction.Unique(a))
If ZeroBased Then ReDim Preserve tmp(0 To UBound(tmp) - 1)
getUniques = tmp
End Function
OK I did it finally:
Sub CountUniqueRecords()
Dim Array() as variant, UniqueArray() as variant, UniqueNo as Integer,
Dim i as integer, j as integer, k as integer
Redim UnquiArray(1)
k= Upbound(array)
For i = 1 To k
For j = 1 To UniqueNo + 1
If Array(i) = UniqueArray(j) Then GoTo Nx
Next j
UniqueNo = UniqueNo + 1
ReDim Preserve UniqueArray(UniqueNo + 1)
UniqueArray(UniqueNo) = Array(i)
Nx:
Next i
MsgBox UniqueNo
End Sub
one more way ...
Sub get_unique()
Dim unique_string As String
lr = Sheets("data").Cells(Sheets("data").Rows.Count, 1).End(xlUp).Row
Set range1 = Sheets("data").Range("A2:A" & lr)
For Each cel In range1
If Not InStr(output, cel.Value) > 0 Then
unique_string = unique_string & cel.Value & ","
End If
Next
End Sub
This VBA function returns an array of distinct values when passed either a range or a 2D array source
It defaults to processing the first column of the source, but you can optionally choose another column.
I wrote a LinkedIn article about it.
Function DistinctVals(a, Optional col = 1)
Dim i&, v: v = a
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next
DistinctVals = Application.Transpose(.Keys)
End With
End Function
The old school method was my favourite option. Thank you. And it was indeed fast. But I didn't use redim. Here though is my real world example where I accumulate values for each unique "key" found in a column and move it into a array (say for an employee and values are hours worked per day). Then I put each key with its final values into a totals area on the active sheet. I've commented extensively for anyone who wants painful detail on what is happening here. Limited error checking is done by this code.
Sub GetActualTotals()
'
' GetActualTotals Macro
'
' This macro accumulates values for each unique employee from the active
' spreadsheet.
'
' History
' October 2016 - Version 1
'
' Invocation
' I created a button labeled "Get Totals" on the Active Sheet that invokes
' this macro.
'
Dim ResourceName As String
Dim TotalHours As Double
Dim TotalPercent As Double
Dim IsUnique As Boolean
Dim FirstRow, LastRow, LastColumn, LastResource, nUnique As Long
Dim CurResource, CurrentRow, i, j As Integer
Dim Resource(1000, 2) As Variant
Dim Rng, r As Range
'
' INITIALIZATIONS
'
' These are index numbers for the Resource array
'
Const RName = 0
Const TotHours = 1
Const TotPercent = 2
'
' Set the maximum number of resources we'll
' process.
'
Const ResourceLimit = 1000
'
' We are counting on there being no unintended data
' in the spreadsheet.
'
' It won't matter if the cells are empty though. It just
' may take longer to run the macro.
' But if there is data where this macro does not expect it,
' assume unpredictable results.
'
' There are some hardcoded values used.
' This macro just happens to expect the names to be in Column C (or 3).
'
' Get the last row in the spreadsheet:
'
LastRow = Cells.Find(What:="*", _
After:=Range("C1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'
' Furthermore, this macro banks on the first actual name to be in C6.
' so if the last row is row 65, the range we'll work with
' will evaluate to "C6:C65"
'
FirstRow = 6
Rng = "C" & FirstRow & ":C" & LastRow
Set r = Range(Rng)
'
' Initialize the resource array to be empty (even though we don't really
' need to but I'm old school).
'
For CurResource = 0 To ResourceLimit
Resource(CurResource, RName) = ""
Resource(CurResource, TotHours) = 0
Resource(CurResource, TotPercent) = 0
Next CurResource
'
' Start the resource counter at 0. The counter will represent the number of
' unique entries.
'
nUnique = 0
'
' LET'S GO
'
' Loop from the first relative row and the last relative row
' to process all the cells in the spreadsheet we are interested in
'
For i = 1 To LastRow - FirstRow
'
' Loop here for all unique entries. For any
' new unique entry, that array element will be
' initialized in the second if statement.
'
IsUnique = True
For j = 1 To nUnique
'
' If the current row element has a resource name and is already
' in the resource array, then accumulate the totals for that
' Resource Name. We then have to set IsUnique to false and
' exit the for loop to make sure we don't populate
' a new array element in the next if statement.
'
If r.Cells(i, 1).Value = Resource(j, RName) Then
IsUnique = False
Resource(j, TotHours) = Resource(j, TotHours) + _
r.Cells(i, 4).Value
Resource(j, TotPercent) = Resource(j, TotPercent) + _
r.Cells(i,5).Value
Exit For
End If
Next j
'
' If the resource name is unique then copy the initial
' values we find into the next resource array element.
' I ignore any null cells. (If the cell has a blank you might
' want to add a Trim to the cell). Not much error checking for
' the numerical values either.
'
If ((IsUnique) And (r.Cells(i, 1).Value <> "")) Then
nUnique = nUnique + 1
Resource(nUnique, RName) = r.Cells(i, 1).Value
Resource(nUnique, TotHours) = Resource(nUnique, TotHours) + _
r.Cells(i, 4).Value
Resource(nUnique, TotPercent) = Resource(nUnique, TotPercent) + _
r.Cells(i, 5).Value
End If
Next i
'
' Done processing all rows
'
' (For readability) Set the last resource counter to the last value of
' nUnique.
' Set the current row to the first relative row in the range (r=the range).
'
LastResource = nUnique
CurrentRow = 1
'
' Populate the destination cells with the accumulated values for
' each unique resource name.
'
For CurResource = 1 To LastResource
r.Cells(CurrentRow, 7).Value = Resource(CurResource, RName)
r.Cells(CurrentRow, 8).Value = Resource(CurResource, TotHours)
r.Cells(CurrentRow, 9).Value = Resource(CurResource, TotPercent)
CurrentRow = CurrentRow + 1
Next CurResource
End Sub
The VBA script below looks for all unique values from cell B5 all the way down to the very last cell in column B… $B$1048576. Once it is found, they are stored in the array (objDict).
Private Const SHT_MASTER = “MASTER”
Private Const SHT_INST_INDEX = “InstrumentIndex”
Sub UniqueList()
Dim Xyber
Dim objDict As Object
Dim lngRow As Long
Sheets(SHT_MASTER).Activate
Xyber = Application.Transpose(Sheets(SHT_MASTER).Range([b5], Cells(Rows.count, “B”).End(xlUp)))
Sheets(SHT_INST_INDEX).Activate
Set objDict = CreateObject(“Scripting.Dictionary”)
For lngRow = 1 To UBound(Xyber, 1)
If Len(Xyber(lngRow)) > 0 Then objDict(Xyber(lngRow)) = 1
Next
Sheets(SHT_INST_INDEX).Range(“B1:B” & objDict.count) = Application.Transpose(objDict.keys)
End Sub
I have tested and documented with some screenshots of the this solution. Here is the link where you can find it....
http://xybernetics.com/techtalk/excelvba-getarrayofuniquevaluesfromspecificcolumn/
If you don't mind using the Variant data type, then you can use the in-built worksheet function Unique as shown.
sub unique_results_to_array()
dim rng_data as Range
set rng_data = activesheet.range("A1:A10") 'enter the range of data here
dim my_arr() as Variant
my_arr = WorksheetFunction.Unique(rng_data)
first_val = my_arr(1,1)
second_val = my_arr(2,1)
third_val = my_arr(3,1) 'etc...
end sub
If you are not interested in the count function, then you could simplify the dictionary approach by using empty quotes for the dictionary value instead of the counter. The following code assumes the first cell containing data is "A1". Alternatively, you could use the Selection (though I understand that is generally frowned upon) or the sheet's UsedRange attribute as your range.
Both of the following examples assume that you want to omit blank values from your array of unique values.
Note that to utilize dictionary objects as follows, you must have the Microsoft Scripting Runtime library active in your references. Also note that by declaring dict as a New Dictionary instead of a Dictionary in the beginning, you can forgo the step of setting it equal to a Scripting Dictionary later. Also, dictionary keys must be unique, and this method does not result in errors when setting the value corresponding to a given dictionary key, so there is no risk of having unique keys.
Sub GetUniqueValuesInRange()
Dim cll As Range
Dim rng As Range
Dim dict As New Dictionary
Dim vArray As Variant
Set rng = Range("A1").CurrentRegion.Columns(1)
For Each cll In rng.Cells
If Len(cll.Value) > 0 Then
dict(cll.Value) = ""
End If
Next cll
vArray = dict.Keys
End Sub
The prior example is a slower method, as it is generally preferred to move the values into an array in the beginning, so that all calculations can be performed in the memory. The following should work faster for larger data sets:
Sub GetUniqueValuesInRange2()
Dim vFullArray As Variant
Dim var As Variant
Dim dict As New Dictionary
Dim vUniqueArray As Variant
vFullArray = Range("A1").CurrentRegion.Columns(1).Value
For Each var In vFullArray
If Len(var) > 0 Then
dict(var) = ""
End If
Next var
vUniqueArray = dict.Keys
End Sub