Related
Using Application.Match Function but unable to know how to paste the Col"M" data into Col"P" after the Matching the Col"O" and Col"L".
When run the Current function it gives the count of match.
Any help will be appreciated.
Dim k As Integer
For k = 2 To 9
ws2.Cells(k, 16).Value = Application.Match(ws2.Cells(k, 15).Value, ws2.Range("L2:L9"), 0)
Next k
I have edited the code with the columns and in which column the result is required. But unable to make changes I really appreciate your help that you make this function. I added some comments may it can help.
' Sheet2 Col"C" with ID's
With ws2
Dim lastRow As Long
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim originalData() As Variant
originalData = .Range("C2:C" & lastRow).Value
End With
' Sheet2 Col"C" with ID's
With ws3
Dim lastRow2 As Long
lastRow2 = .Range("A" & .Rows.Count).End(xlUp).Row
Dim newData() As Variant
newData = .Range("C2:C" & lastRow2).Value
End With
Dim i As Long
For i = LBound(newData, 1) To UBound(newData, 1)
Dim j As Long
For j = LBound(originalData, 1) To UBound(originalData, 2)
If newData(i, 1) = originalData(j, 1) Then
newData(i, 2) = originalData(j, 2)
Exit For
End If
Next
Next
'Sheet2 Col"K" where Sheet3 Col"E" data will be pasted
ws2.Range("K2:K" & lastRow).Value = newData
A scripting dictionary which maps "keys" to "values" is typically the fastest approach when you need to perform a lot of lookups. It's a bit more code to write but should be quick.
Sub DoLookup()
Dim arrKeys, arrValues, wsData As Worksheet, wsDest As Worksheet
Dim map As Object, rngSearch As Range, rngResults As Range, k, v, n As Long
Set wsData = ThisWorkbook.Worksheets("Sheet3") 'sheet with the lookup table
Set wsDest = ThisWorkbook.Worksheets("Sheet2") 'sheet to be populated
arrKeys = wsData.Range("C2:C" & LastRow(wsData, "C")).Value 'keys in the lookup table
arrValues = wsData.Range("G2:G" & LastRow(wsData, "C")).Value 'values in the lookup table
Set map = MapValues(arrKeys, arrValues) 'get a map of Keys->Values
Set rngSearch = wsDest.Range("C2:C" & LastRow(wsDest, "c")) 'keys to look up
Set rngResults = rngSearch.EntireRow.Columns("K") 'results go here
arrKeys = rngSearch.Value 'keys to look up
arrValues = rngResults.Value 'array to populate with results
For n = 1 To UBound(arrKeys) 'loop over keys to look up
v = "" 'or whatever you want to see if no match
k = arrKeys(n, 1)
If map.exists(k) Then v = map(k)
arrValues(n, 1) = v
Next n
rngResults.Value = arrValues 'populate the results array back to the sheet
End Sub
'Return a Scripting Dictionary linking "keys" to "values"
' Note - assumes same-size single-column inputs, and that keys are unique,
' otherwise you just map to the *last* value for any given key
Function MapValues(arrKeys, arrValues)
Dim n, dict As Object, k
Set dict = CreateObject("scripting.dictionary")
For n = 1 To UBound(arrKeys, 1)
k = CStr(arrKeys(n, 1)) 'string keys are faster to add?
If Len(k) > 0 Then dict(k) = arrValues(n, 1)
Next n
Set MapValues = dict
End Function
'utility function
Function LastRow(ws As Worksheet, col As String) As Long
LastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
End Function
In my test workbook this was able to perform 10k lookups against a table of 10k rows in <0.1 sec.
You always should test if the Match succeeded, using IsError.
Then use Cells:
Dim k As Long
For k = 2 To 9
Dim m As Variant
m = Application.Match(ws2.Cells(k, 15).Value, ws2.Range("L2:L9"), 0)
If Not IsError(m) Then
ws2.Cells(k, 16).Value = ws2.Range("M2:M9").Cells(m)
End If
Next
I have a table in excel and I want to have the records displayed in a userform using the listview control. The challange I'm facing is that I only want 5 columns to be displayed and only unique rows.
The code I have so far is as follows:
Private Sub LoadListView()
Dim wksSource As Worksheet
Dim rngData, rngCell As Range
Dim LstItem As ListItem
Dim RowCount, ColCount, i, j As Long
Dim CountryCol, ShippingWay, SortCode, FirstException, LastException, Performance_OK_NOK, Container,
CountSimilar, a As Integer
Set wksSource = Worksheets("Sheet3")
Set rngData = wksSource.Range("A1").CurrentRegion
Me.ListView1.ColumnHeaders.Add Text:="RowNr", Width:=70
For Each rngCell In rngData.Rows(1).Cells
If rngCell = "service_def_code" Or rngCell = "package_sort" Or rngCell = "ship_to_country_id" Or
rngCell = "first_tracking_exception_message" _
Or rngCell = "last_tracking_exception_message" Then
Me.ListView1.ColumnHeaders.Add Text:=rngCell.Value, Width:=80
End If
Next rngCell
RowCount = rngData.Rows.Count
ColCount = rngData.Columns.Count
For i = 1 To ColCount
If wksSource.Cells(1, i) = "ship_to_country_id" Then
CountryCol = i
ElseIf wksSource.Cells(1, i) = "service_def_code" Then
ShippingWay = i
ElseIf wksSource.Cells(1, i) = "package_sort" Then
SortCode = i
ElseIf wksSource.Cells(1, i) = "first_tracking_exception_message" Then
FirstException = i
ElseIf wksSource.Cells(1, i) = "last_tracking_exception_message" Then
LastException = i
ElseIf wksSource.Cells(1, i) = "performance_result" Then
Performance_OK_NOK = i
End If
Next i
j = 1
For i = 2 To RowCount
If wksSource.Cells(i, Performance_OK_NOK) = "NOK" then
Set LstItem = Me.ListView1.ListItems.Add(Text:=j)
LstItem.ListSubItems.Add Text:=rngData(i, CountryCol)
LstItem.ListSubItems.Add Text:=rngData(i, ShippingWay)
LstItem.ListSubItems.Add Text:=rngData(i, SortCode)
LstItem.ListSubItems.Add Text:=rngData(i, FirstException)
LstItem.ListSubItems.Add Text:=rngData(i, LastException)
j = j + 1
end if
next i
end sub
So what I want to do is to have only unique rows displayed and the subitems represents a row. I checked and searched for a solution, but couldn't find one which I understand. Can someone please help?
you can use a dictionary. For each row create a key with the values of the five columns. if it is not in the dictionary, add it to the dictionary, add it to the listview.
The below example creates a key from columns a, b. Adapt it so you create your key based on your five columns. below i only get "b2" once even though it appears twice in table(cols a,b)
Public Sub sAddToList()
'REQUIRES MICROSOFT SCRIPTING RUNTIME LIB, (Add using Tools->References from the VB menu)
Dim d As Dictionary
Dim rowKey As String
Dim i As Integer
Set d = New Dictionary
For i = 1 To 4
rowKey = CStr(Sheet1.Cells(i, 1).Value) + CStr(Sheet1.Cells(i, 2).Value)
If Not d.Exists(rowKey) Then
d.Add rowKey, rowKey
'add to your list view
End If
Next
End Sub
IF YOUR EXCEL SUPPORTS the UNIQUE function then there is no need for VBA.
I need to create a list of part numbers, which shows all other sub parts that are used to create that first part.
So for example part 12345 is built by combining abc and def.
I have a list of the top level parts, and a second list with two columns showing the top level on the left, and the sub part on the right.
e.g:
| Top Level Part | | Top Level Part | Sub Part |
| 123456 | | 123456 | abc |
| 234567 | | 123456 | def |
| 234567 | ghi |
| 234567 | jkl |
| abc | yyy |
| abc | zzz |
| yyy | 000000 |
I have used a for each loop to look through each part in the first table and compare it to the second, returning each sub part to the right. However I am struggling to go deeper than one level.
What I want to be able to do is once the sub part is found to loop back through the list looking for that part number and returning it's sub part. And continuing until the part is no longer found. Effectively giving me a tree.
-123456
--abc
---yyy
----000000
---zzz
--def
-234567
--ghi
--jkl
The loop I am using initially is this:
Dim topList as range, top as range
Dim lookupList as range, lookup as range
Dim i as integer
Set topList = .sheets("Sheet1").range("A2:A100")
set lookupList = .sheets("Sheet2").Range("A2:A1000")
i = 1
For Each top in topList
For Each lookup in lookupList
If (top = lookup) then
top.offset(0, i).value = lookup.offset(0, 1))
i = i + 1
End If
Next lookup
Next top
I have considered using a while loop inside of this which would re scan the list for the sub part, changing the variable to the new part number each time one is found, and stop running once the part doesn't exist in the list.
I can't come up with a working way to implement this though.
i tried using dictionaries and a recursive function to present the results. you can tweak it a bit to only show the top parts. Currently it shows every item that is in column A. Column C is the output.
The idea is that i am looping through the column A and i create a dictionary for each part and has entries in the dictionary the sub parts.
When i present the results if an entry in the dictionary is also an entry in my top level dictionary i present it again.
Public Sub sFindParts()
Dim topPartDict As New Dictionary, subPartDict As Dictionary, d As Dictionary
Dim topPartList As Range, part As Range
Dim outputLocation As Range
Dim i As Integer, indLvl As Integer
Dim k As Variant, p As Variant
Set outputLocation = Sheet2.Range("C1")
Set topPartList = Sheet2.Range("A2:A8")
For Each part In topPartList
If Not topPartDict.Exists(part.Value) Then
Set d = New Dictionary
d.Add Key:=part.Offset(0, 1).Value, item:=part.Offset(0, 1).Value
topPartDict.Add Key:=part.Value, item:=d
Set topPartDict(part.Value) = d
Else
Set d = topPartDict(part.Value)
d.Add Key:=part.Offset(0, 1).Value, item:=part.Offset(0, 1).Value
Set topPartDict(part.Value) = d
End If
Next part
indLvl = fPresentParts(outputLocation, topPartDict, topPartDict, 0)
End Sub
Private Function fPresentParts(ByRef location As Range, ByRef tpd As Dictionary, ByRef d As Dictionary, indLvl As Integer) As Integer
Dim k As Variant, v As Variant
Dim subPartsDict As Dictionary
For Each k In d.Keys()
If TypeOf d(k) Is Dictionary Then
Set v = d(k)
location.IndentLevel = indLvl
location.Value = k
Set location = location.Offset(1, 0)
indLvl = indLvl + 1
Set subPartsDict = v
indLvl = fPresentParts(location, tpd, subPartsDict, indLvl)
Else
If tpd.Exists(d(k)) And TypeOf tpd(d(k)) Is Dictionary Then
location.IndentLevel = indLvl
location.Value = d(k)
Set location = location.Offset(1, 0)
indLvl = indLvl + 1
indLvl = fPresentParts(location, tpd, tpd(d(k)), indLvl)
Else
location.IndentLevel = indLvl
location.Value = k
Set location = location.Offset(1, 0)
End If
End If
Next k
indLvl = indLvl - 1
fPresentParts = indLvl
End Function
I suggest looping through your list of Top Level Part and Sub Part and use the WorksheetFunction.Match Method to backwards trace the path of each entry.
Outgoing from this list Worksheets("List"):
It will return Worksheets("Output"):
Which only needs to be sorted by columns A B C and D to get the tree view character.
Option Explicit
Public Sub FindPathway()
Dim wsList As Worksheet
Set wsList = ThisWorkbook.Worksheets("List")
Dim wsOutput As Worksheet
Set wsOutput = ThisWorkbook.Worksheets("Output")
Dim LastRow As Long
LastRow = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row
Dim OutputRow As Long, oCol As Long
OutputRow = 2
Dim PathCol As Collection
Dim FoundRow As Long
Dim iRow As Long, cRow As Long
For iRow = 2 To LastRow
cRow = iRow
Set PathCol = New Collection
PathCol.Add wsList.Cells(cRow, "B").Value
Do 'loop until a root item is found
FoundRow = 0
On Error Resume Next
FoundRow = WorksheetFunction.Match(wsList.Cells(cRow, "A"), wsList.Columns("B"), 0)
On Error GoTo 0
If FoundRow = 0 Then
'is a root
PathCol.Add wsList.Cells(cRow, "A").Value
For oCol = 0 To PathCol.Count - 1 'output all remembered items
wsOutput.Cells(OutputRow, oCol + 1).Value = PathCol.Item(PathCol.Count - oCol)
Next oCol
OutputRow = OutputRow + 1
Else
'is a child
PathCol.Add wsList.Cells(cRow, "A").Value 'remember item
cRow = FoundRow 'go for the next child item
End If
DoEvents 'prevent unresponsive Excel
Loop Until FoundRow = 0
Next iRow
End Sub
Note that this method is very basic and not the fastest, because it doesn't recognize already traced paths, instead it always does a full trace for every item.
Throwing my hat in the ring. The tgr sub can be customized for where to look for the data and where to output the results. It will also keep track of what is actually top level and only perform the recursive search for those items and their sub parts. The recursive search function is FindAllSubParts
Sub tgr()
Const sDataSheet As String = "Sheet2"
Const sResultSheet As String = "Sheet1"
Const sTopPartsCol As String = "A"
Const sSubPartsCol As String = "B"
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rTopParts As Range
Dim rSubParts As Range
Dim TopPartCell As Range
Dim rTest As Range
Dim hTopParts As Object
Set wb = ActiveWorkbook
Set wsData = wb.Sheets(sDataSheet)
Set wsDest = wb.Sheets(sResultSheet)
Set rTopParts = wsData.Range(sTopPartsCol & "2", wsData.Cells(wsData.Rows.Count, sTopPartsCol).End(xlUp))
Set rSubParts = Intersect(rTopParts.EntireRow, wsData.Columns(sSubPartsCol))
Set hTopParts = CreateObject("Scripting.Dictionary")
For Each TopPartCell In rTopParts.Cells
Set rTest = Nothing
Set rTest = rSubParts.Find(TopPartCell.Text, rSubParts.Cells(rSubParts.Cells.Count), xlValues, xlWhole, , xlNext, False)
If rTest Is Nothing And Not hTopParts.Exists(TopPartCell.Text) Then
hTopParts.Add TopPartCell.Text, TopPartCell.Text
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Value = TopPartCell.Text
FindAllSubParts TopPartCell.Text, 1, rTopParts, rSubParts, wsDest, sTopPartsCol
End If
Next TopPartCell
End Sub
Sub FindAllSubParts(ByVal arg_sTopPart As String, _
ByVal arg_lSubIndex As Long, _
ByVal arg_rTopParts As Range, _
ByVal arg_rSubParts As Range, _
ByVal arg_wsDest As Worksheet, _
ByVal arg_sTopPartsCol As String)
Dim rFound As Range
Dim sFirst As String
Dim sSubPart As String
Set rFound = arg_rTopParts.Find(arg_sTopPart, arg_rTopParts.Cells(arg_rTopParts.Cells.Count), xlValues, xlWhole, , xlNext, False)
If Not rFound Is Nothing Then
sFirst = rFound.Address
Do
sSubPart = arg_rSubParts.Parent.Cells(rFound.Row, arg_rSubParts.Column).Text
arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_sTopPartsCol).End(xlUp).Offset(1).Value = String(arg_lSubIndex, "-") & sSubPart
FindAllSubParts sSubPart, arg_lSubIndex + 1, arg_rTopParts, arg_rSubParts, arg_wsDest, arg_sTopPartsCol
Set rFound = arg_rTopParts.Find(arg_sTopPart, rFound, xlValues, xlWhole, , xlNext, False)
Loop While rFound.Address <> sFirst
End If
End Sub
bear with me on this question. I'm pretty sure it'll be easy for those who have knowledge in this field, but I do not know much about VBA or how to create loops in Excel to be creating this formula:
Please review the picture here
What I'm trying to construct is a loop that'll concatenate those numbers.
EX. I want to concatenate in this order A2,"-",B2; A3,"-",B2; A4,"-",B2.....A16,"-",B2
Once everything in A1- A16 is concatenated with B2, I want to move on to concatenating A1-A16 with B3.EX: A2,"-",B3; A3,"-",B3.....A16,"-",B3
I know this is possible because certain loops can be created to go through with this procedure, but I do not know VBA and am not sure if this is possible with just the pre-existing formulas in Excel. Thanks to anyone who helps.
From what you described, it's pretty simple nested loop. Below code will concatenate the way you wanted and store it to column C.
Sub MyConcat()
Const lColA As Long = 1
Const lColB As Long = 2
Const lColTxt As Long = 3 ' concatenated result in Column C
Dim oWS As Worksheet, sTxt As String
Dim lRowA As Long, lRowB As Long, lRowTxt As Long
Set oWS = ThisWorkbook.Worksheets("Sheet1") ' Change this to match yours
lRowA = 1
lRowTxt = 1
oWS.Columns(lColTxt).Clear ' remove previous data on Column C
Do Until IsEmpty(oWS.Cells(lRowA, lColA))
sTxt = ""
lRowB = 2
Do Until IsEmpty(oWS.Cells(lRowB, lColB))
sTxt = oWS.Cells(lRowA, lColA).Text & "-" & oWS.Cells(lRowB, lColB).Text
oWS.Cells(lRowTxt, lColTxt) = sTxt
lRowB = lRowB + 1
lRowTxt = lRowTxt + 1
Loop
lRowA = lRowA + 1
Loop
Set oWS = Nothing
End Sub
EDIT: This should fit in many situations of number of Parent SKUs.
Usable on your data in second image, including another set of "TuTi" and Parent SKUs of different length. Please try understand it, it will be a whole page of explanations.
Private Const lColA As Long = 1
Private Const lColB As Long = 2
Private Const lColTxt As Long = 3 ' concatenated result in Column C
Dim oWS As Worksheet, sGroup As String, lRowCurr As Long, lRowTxt As Long
Sub MyConcat()
Dim oRng As Range, lStopRow As Long
Set oWS = ThisWorkbook.Worksheets("Sheet1") ' Change this to match yours
lRowCurr = 1 ' Current Row index
lRowTxt = 1 ' Results from Row 1
sGroup = ""
With oWS
.Columns(lColTxt).Clear ' remove previous data on Column C
' Row of LastCell in current sheet + 1
lStopRow = .Cells.SpecialCells(xlLastCell).Row + 1
' Row of "Ctrl-Up" from LastCell Row at column A
lStopRow = .Cells(lStopRow, lColA).End(xlUp).Row + 1
' Start processing rows until until StopRow in column A
Do Until lRowCurr = lStopRow
Set oRng = .Cells(lRowCurr, lColA)
If IsGroupCell(oRng) Then
sGroup = oRng.Value ' Stores Group text
ElseIf IsParentSKU(oRng) Then
Call MyConcat2 ' Invoke the mix sub that writes the result in column C
End If
lRowCurr = lRowCurr + 1
Set oRng = Nothing
Loop
End With
Set oWS = Nothing
End Sub
Private Sub MyConcat2()
Dim sTxt As String, oRng As Range
Dim lRowA As Long, lRowB As Long
lRowA = lRowCurr + 1
Set oRng = oWS.Cells(lRowA, lColA)
' Stop mixing the values when it is a Group or Parent SKU row
Do Until IsGroupCell(oRng) Or IsParentSKU(oRng) Or IsEmpty(oRng)
sTxt = ""
lRowB = lRowCurr + 1
' Don't mix if it is a Parent SKU
Do Until IsParentSKU(oWS.Cells(lRowB, lColA)) Or IsEmpty(oWS.Cells(lRowB, lColB))
sTxt = oWS.Cells(lRowA, lColA).Text & "-" & oWS.Cells(lRowB, lColB).Text
oWS.Cells(lRowTxt, lColTxt) = sGroup & "-" & sTxt
lRowB = lRowB + 1
lRowTxt = lRowTxt + 1
Loop
lRowA = lRowA + 1
Set oRng = oWS.Cells(lRowA, lColA)
Loop
lRowCurr = lRowA - 1
Set oRng = Nothing
End Sub
Private Function IsGroupCell(oRng As Range) As Boolean
IsGroupCell = (Not IsNumeric(Left(oRng.Value, 1)) And IsEmpty(oRng.Offset(0, 1)))
End Function
Private Function IsParentSKU(oRng As Range) As Boolean
IsParentSKU = (IsNumeric(oRng.Value) And IsNumeric(oRng.Offset(0, 1).Value))
End Function
Assume I have a block of data in Excel 2010, 100 rows by 3 columns.
Column C contains some duplicates, say it starts off as
1, 1, 1, 2, 3, 4, 5, ..... , 97, 98
Using VBA, I would like to remove the duplicate rows so I am left with 98 rows and 3 columns.
1, 2, 3, ..... , 97, 98
I know there is a button in Excel 2010 to do that but it inteferes with the rest of my code subsequently and gives incorrect results.
Furthermore, I would like to do it in arrays, then paste the results on the worksheet, rather than methods such as Application.Worksheetfunction.countif(.....
So something like:
Dim myarray() as Variant
myarray=cells(1,1).Currentregion.value
Dim a as Long
For a=1 to Ubound(myarray,1)
'something here to
Next a
I answered a similar question. Here is the code I used:
Dim dict As Object
Dim rowCount As Long
Dim strVal As String
Set dict = CreateObject("Scripting.Dictionary")
rowCount = Sheet1.Range("A1").CurrentRegion.Rows.Count
'you can change the loop condition to iterate through the array rows instead
Do While rowCount > 1
strVal = Sheet1.Cells(rowCount, 1).Value2
If dict.exists(strVal) Then
Sheet1.Rows(rowCount).EntireRow.Delete
Else
'if doing this with an array, then add code in the Else block
' to assign values from this row to the array of unique values
dict.Add strVal, 0
End If
rowCount = rowCount - 1
Loop
Set dict = Nothing
If you want to use an array, then loop through the elements with the same conditional (if/else) statements. If the item doesn't exist in the dictionary, then you can add it to the dictionary and add the row values to another array.
Honestly, I think the most efficient way is to adapt code you'd get from the macro recorder. You can perform the above function in one line:
Sheet1.UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes
Function eliminateDuplicate(poArr As Variant) As Variant
Dim poArrNoDup()
dupArrIndex = -1
For i = LBound(poArr) To UBound(poArr)
dupBool = False
For j = LBound(poArr) To i
If poArr(i) = poArr(j) And Not i = j Then
dupBool = True
End If
Next j
If dupBool = False Then
dupArrIndex = dupArrIndex + 1
ReDim Preserve poArrNoDup(dupArrIndex)
poArrNoDup(dupArrIndex) = poArr(i)
End If
Next i
eliminateDuplicate = poArrNoDup
End Function
Simple function to remove duplicates from a 1D array
Private Function DeDupeArray(vArray As Variant) As Variant
Dim oDict As Object, i As Long
Set oDict = CreateObject("Scripting.Dictionary")
For i = LBound(vArray) To UBound(vArray)
oDict(vArray(i)) = True
Next
DeDupeArray = oDict.keys()
End Function
Edit:
With stdVBA (a library largely maintained by myself) you can use:
uniqueValues = stdEnumerator.CreateFromArray(myArray).Unique().AsArray()
An improvement on #RBILLC and #radoslav006 answers, this version searches the array with the duplicates removed for existing values so it searchs less values to find a duplicate.
Public Function RemoveDuplicatesFromArray(sourceArray As Variant)
Dim duplicateFound As Boolean
Dim arrayIndex As Integer, i As Integer, j As Integer
Dim deduplicatedArray() As Variant
arrayIndex = -1
deduplicatedArray = Array(1)
For i = LBound(sourceArray) To UBound(sourceArray)
duplicateFound = False
For j = LBound(deduplicatedArray) To UBound(deduplicatedArray)
If sourceArray(i) = deduplicatedArray(j) Then
duplicateFound = True
Exit For
End If
Next j
If duplicateFound = False Then
arrayIndex = arrayIndex + 1
ReDim Preserve deduplicatedArray(arrayIndex)
deduplicatedArray(arrayIndex) = sourceArray(i)
End If
Next i
RemoveDuplicatesFromArray = deduplicatedArray
End Function
Here's another approach for working with an array:
Sub tester()
Dim arr, arrout
arr = Range("A1").CurrentRegion.Value 'collect the input array
arrout = UniqueRows(arr) 'get only unique rows
Range("H1").Resize(UBound(arrout, 1), UBound(arrout, 2)).Value = arrout
End Sub
Function UniqueRows(arrIn As Variant) As Variant
Dim keys, rw As Long, col As Long, k, sep, arrout
Dim dict As Object, lbr As Long, lbc As Long, ubr As Long, ubc As Long, rwOut As Long
Set dict = CreateObject("scripting.dictionary")
'input array bounds
lbr = LBound(arrIn, 1)
ubr = UBound(arrIn, 1)
lbc = LBound(arrIn, 2)
ubc = UBound(arrIn, 2)
ReDim keys(lbr To ubr)
'First pass:collect all the row "keys" in an array
' and unique keys in a dictionary
For rw = lbr To ubr
k = "": sep = ""
For col = lbc To ubc
k = k & sep & arrIn(rw, col)
sep = Chr(0)
Next col
keys(rw) = k 'collect key for this row
dict(k) = True 'just collecting unique keys
Next rw
'Resize output array to # of unique rows
ReDim arrout(lbr To dict.Count + (lbr - 1), lbc To ubc)
rwOut = lbr
'Second pass: copy each unique row to the output array
For rw = lbr To ubr
If dict(keys(rw)) Then 'not yet output?
For col = lbc To ubc 'copying this row over to output...
arrout(rwOut, col) = arrIn(rw, col)
Next col
rwOut = rwOut + 1 'increment output "row"
dict(keys(rw)) = False 'flag this key as copied
End If
Next rw
UniqueRows = arrout
End Function
Answer from #RBILLC could be easily improved by adding an Exit For inside internal loop:
Function eliminateDuplicate(poArr As Variant) As Variant
Dim poArrNoDup()
dupArrIndex = -1
For i = LBound(poArr) To UBound(poArr)
dupBool = False
For j = LBound(poArr) To i
If poArr(i) = poArr(j) And Not i = j Then
dupBool = True
Exit For
End If
Next j
If dupBool = False Then
dupArrIndex = dupArrIndex + 1
ReDim Preserve poArrNoDup(dupArrIndex)
poArrNoDup(dupArrIndex) = poArr(i)
End If
Next i
eliminateDuplicate = poArrNoDup
End Function
I think this is really a case for using excel's native functions, at least for the initial array acquisition, and I don't think there's any simpler way to do it. This sub will output the unique values starting in column 5. I assumed that the target range was empty, so if it's not, change r and c.
Sub testUniques()
Dim arr, r As Long, c As Long, h As Long, w As Long
Dim this As Worksheet: Set this = ActiveSheet
arr = Application.Unique(this.Cells(1, 1).CurrentRegion)
r = 1
c = 5
h = UBound(arr, 1) - 1
w = UBound(arr, 2) - 1
this.Range(this.Cells(r, c), this.Cells(r + h, c + w)) = arr
End Sub
I know this is old, but here's something I used to copy duplicate values to another range so that I could see them quickly to establish data integrity for a database I was standing up from various spreadsheets. To make the procedure delete the duplicates it would be as simple as replacing the dupRng lines with Cell.Delete Shift:=xlToLeft or something to that effect.
I haven't tested that personally, but it should work.
Sub PartCompare()
Dim partRng As Range, partArr() As Variant, i As Integer
Dim Cell As Range, lrow As Integer
lrow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
i = 0
Set partRng = ThisWorkbook.Worksheets("Sheet1").Range(Cells(1, 1), Cells(lrow, 1))
For Each Cell In partRng.Cells
ReDim Preserve partArr(i)
partArr(i) = Cell.Value
i = i + 1
Next
Dim dupRng As Range, j As Integer, x As Integer, c As Integer
Set dupRng = ThisWorkbook.Worksheets("Sheet1").Range("D1")
x = 0
c = 1
For Each Cell In partRng.Cells
For j = c To UBound(partArr)
If partArr(j) = Cell.Value Then
dupRng.Offset(x, 0).Value = Cell.Value
dupRng.Offset(x, 1).Value = Cell.Address()
x = x + 1
Exit For
End If
Next j
c = c + 1
Next Cell
End Sub
Remove duplicates (plus related row items) from array
As OP wanted a VBA solution close to RemoveDuplicates, I demonstrate an array approach using a â–ºdictionary to get not the unique items per se (dict.keys), but the related row indices of first occurrencies (dict.items).
These are used to retain the whole row data via procedure LeaveUniques profiting from the advanced possibilities of the â–ºApplication.Index() function - c.f. Some peculiarities of the the Application.Index function
Example Call
Sub ExampleCall()
'[0]define range and assign data to 1-based 2-dim datafield
With Sheet1 ' << reference to your project's sheet Code(Name)
Dim lastRow: lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Dim rng: Set rng = .Range("C2:E" & lastRow)
End With
Dim data: data = rng ' assign data to 2-dim datafield
'[1]get uniques (column 1) and remove duplicate rows
LeaveUniques data ' << call procedure LeaveUniques (c.f. RemoveDuplicates)
'[2]overwrite original range
rng.Clear
rng.Resize(UBound(data), UBound(data, 2)) = data
End Sub
Procedure LeaveUniques
Sub LeaveUniques(ByRef data As Variant, Optional ByVal colNum As Long = 1)
'Purpose: procedure removes duplicates of given column number in entire array
data = Application.Index(data, uniqueRowIndices(data, colNum), nColIndices(UBound(data, 2)))
End Sub
Help functions to LeaveUniques
Function uniqueRowIndices(data, Optional ByVal colNum As Long = 1)
'Purpose: return data index numbers referring to uniques
'a) set late bound dictionary to memory
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
'b) slice e.g. first data column (colNum = 1)
Dim colData
colData = Application.Index(data, 0, colNum)
'c) fill dictionary with uniques referring to first occurencies
Dim i As Long
For i = 1 To UBound(colData)
If Not dict.exists(dict(colData(i, 1))) Then dict(colData(i, 1)) = i
Next
'd) return 2-dim array of valid unique 1-based index numbers
uniqueRowIndices = Application.Transpose(dict.items)
End Function
Function nColIndices(ByVal n As Long)
'Purpose: return "flat" array of n column indices, e.g. for n = 3 ~> Array(1, 2, 3)
nColIndices = Application.Transpose(Evaluate("row(1:" & n & ")"))
End Function