Remove duplicated data without counting order - excel

I have the following data
0/3, 1/1, 3/4
1/3, 3/2, 6/2
12/1, 3/6, 3/4
3/4, 0/3, 1/1 'will be considered is duplicate with the first data
Is there any way to find and remove duplicate data like this?
My current method is to split into 3 strings based on "," then check with the following condition.
'I got each String value by mid command.
'FrstStr1: First String of String 1
'SecStr1: Second String of String 1
'ThrStr1: Third String of String 1
'FrstStr2: First String of String 2
'SecStr2: Second String of String 2
'ThrStr2: Third String of String 2
if (FrstStr1 = FrstStr2 and SecStr1 = SecStr2 and ThrStr1 = ThrStr2) or
(FrstStr1 = FrstStr2 and SecStr1 = ThrStr2 and ThrStr1 = SecStr2) or
() or () .... then
I listed 6 possible cases and put them into if condition like above.

Make Array by Spliting data with delimiter comma.
And Sorting Array by function.
Ceck duplicated data by Dictionary.
## Code ##
Sub test()
Dim vR(), vDB
Dim dic As Object
Dim v As Variant
Dim s As String
Dim i As Long, n As Long
Set dic = CreateObject("Scripting.Dictionary")
vDB = Range("a1").CurrentRegion
For i = 1 To UBound(vDB, 1)
v = Split(vDB(i, 1), ",")
s = newArray(v)
If dic.exists(s) Then
Else
dic.Add s, s
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, 1)
End If
Next i
If n Then
Range("e1").Resize(n) = WorksheetFunction.Transpose(vR)
End If
End Sub
Function newArray(v As Variant)
Dim temp As String
Dim r As Integer, i As Integer, j As Integer
r = UBound(v)
For i = LBound(v) To r - 1
For j = i + 1 To r
v(i) = Trim(v(i))
v(j) = Trim(v(j))
If v(i) > v(j) Then
temp = v(j)
v(j) = v(i)
v(i) = temp
End If
Next j
Next i
newArray = Join(v, ",")
End Function
Image

expoliting Dictionary and ArrayList objects could lead to a very compact (and maintanable) code:
Sub RemoveDuplicatedDataWithoutCountingOrder()
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim j As Long
Dim key As String
Dim datum As Variant, couple As Variant
For Each datum In Range("A1").CurrentRegion.Value
key = vbNullString
With CreateObject("System.Collections.SortedList")
For Each couple In Split(Replace(datum, " ", vbNullString), ",")
.Add couple, 0
Next
For j = 0 To .Count - 1
key = key & .getkey(j)
Next
If Not dict.exists(key) Then dict.Add key, datum
End With
Next
Range("C1").Resize(dict.Count) = Application.Transpose(dict.items)
End Sub

Related

Convert vertical to horizontal on multiple columns

I have a code that converts a column from vertical state to horizontal (each group to be in one row)
Here's some dummy data
Groups Amount Notes Name
A 10 N1 GroupA
A 20 N2 GroupA
A 30 N3 GroupA
B 40 N4 GroupB
B 50 N5 GroupB
B 60 N6 GroupB
B 70 N7 GroupB
C 80 N8 GroupC
D 90 N9 GroupD
D 100 N10 GroupD
Here's the code that deals with the second column only
Sub Test()
Dim v, a, i As Long
v = Cells(1).CurrentRegion
ReDim b(UBound(v) + 1)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(v)
a = .Item(v(i, 1))
If IsEmpty(a) Then a = b
a(0) = v(i, 1)
a(UBound(a)) = a(UBound(a)) + 1
a(a(UBound(a))) = v(i, 2)
.Item(v(i, 1)) = a
Next i
Range("G2").Resize(.Count, UBound(a) - 1) = Application.Index(.Items, 0)
End With
End Sub
The code works fine for the second column, but I need to deal with the third column too with the same idea. And as for the fourth column will be just once (in the output would be in one column)
Here's the expected output
The solution to your problem is a little more complicated than it first seems. But kudos to you for using a Dictionary rather than trying to do everything via arrays.
The code below uses a Dictionary whose keys are the values in the Groups column. The Item associated with these keys is an Arraylist. In turn, the Arraylist is populated with Arraylists comprising the Amount,Note and Nname values for each row corresponding to the Key in the Group Column. The Arraylist is used because we can easily delete items from An Arraylist.
Note that the Item method of Scripting.Dictionaries and ArrayLists is the default method, and for this reason I don't explicity invoke the Item method in the code. If the default method were something other than Item, then I would have specifically stated the default method.
The code below is a good deal longer than in your original post, but I will hope you will see how things have been split up into logical tasks.
You will also see that I use vertical spacing a lot to break codee withing methods into 'paragraphs'. This is a personal preference.
Public Sub Test2()
Dim myD As Scripting.Dictionary
Set myD = GetCurrentRegionAsDictionary(Cells(1).CurrentRegion)
Dim myArray As Variant
myArray = GetPopulatedOutputArray(myD)
Dim Destination As Range
Set Destination = Range("A20")
Destination.Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray
End Sub
'#Description("Returns an Array in the desired output format from the contents of the Scripting.Dictionary created from the CurrentRegion")
Public Function GetPopulatedOutputArray(ByRef ipD As Scripting.Dictionary) As Variant
Dim myAmountSpan As Long
myAmountSpan = MaxSubArrayListSize(ipD)
Dim myArray As Variant
ReDim myArray(1 To ipD.Count, 1 To 2 + myAmountSpan * 2)
Dim myHeaderText As Variant
myHeaderText = GetHeaderTextArray(ipD, myAmountSpan)
Dim myIndex As Long
For myIndex = 0 To UBound(myHeaderText)
myArray(1, myIndex + 1) = myHeaderText(myIndex)
Next
Dim myRow As Long
myRow = 2
Dim myKey As Variant
For Each myKey In ipD
myArray(myRow, 1) = myKey
Dim myCol As Long
myCol = 2
Dim myList As Variant
For Each myList In ipD(myKey)
myArray(myRow, myCol) = myList(0)
myArray(myRow, myCol + myAmountSpan) = myList(1)
If VBA.IsEmpty(myArray(myRow, UBound(myArray, 2))) Then
myArray(myRow, UBound(myArray, 2)) = myList(2)
End If
myCol = myCol + 1
Next
myRow = myRow + 1
Next
GetPopulatedOutputArray = myArray
End Function
'#Description("Returns an array contining the appropriately formatted header text")
Public Function GetHeaderTextArray(ByRef ipD As Scripting.Dictionary, ByVal ipAmountSpan As Long) As Variant
' The Scripting.Dictionary does not maintain order of addition
' so we need to search for a key longer than one character
Dim myFoundKey As String
Dim myHeaderList As ArrayList
Dim myKey As Variant
For Each myKey In ipD
If Len(myKey) > 2 Then
myFoundKey = myKey
Set myHeaderList = ipD(myKey)(0)
Exit For
End If
Next
Dim myT As String
myT = myFoundKey & ","
Dim myIndex As Long
For myIndex = 1 To ipAmountSpan
myT = myT & myHeaderList(0) & CStr(myIndex) & ","
Next
For myIndex = 1 To ipAmountSpan
myT = myT & myHeaderList(1) & CStr(myIndex) & ","
Next
myT = myT & myHeaderList(2)
' removeove the header text as it is no longer needed
ipD.Remove myFoundKey
GetHeaderTextArray = Split(myT, ",")
End Function
'#Description("Returns a Dictionary of arraylists using column 1 of the current region as the key
Public Function GetCurrentRegionAsDictionary(ByRef ipRange As Excel.Range) As Scripting.Dictionary
Dim myArray As Variant
myArray = ipRange.Value
Dim myD As Scripting.Dictionary
Set myD = New Scripting.Dictionary
Dim myRow As Long
For myRow = LBound(myArray, 1) To UBound(myArray, 1)
Dim myList As ArrayList
Set myList = GetRowAsList(myArray, myRow)
Dim myKey As Variant
Assign myKey, myList(0)
myList.RemoveAt 0
If Not myD.Exists(myKey) Then
myD.Add myKey, New ArrayList
End If
' Add an arraylist to the arraylist specified by Key
myD.Item(myKey).Add myList
Next
Set GetCurrentRegionAsDictionary = myD
End Function
'#Description("Get the size of largest subArrayList")
Public Function MaxSubArrayListSize(ByRef ipD As Scripting.Dictionary) As Long
Dim myMax As Long
myMax = 0
Dim myKey As Variant
For Each myKey In ipD
If ipD(myKey).Count > myMax Then
myMax = ipD(myKey).Count
End If
Next
MaxSubArrayListSize = myMax
End Function
'#Description("Returns a row of an Array as an ArrayList")
Public Function GetRowAsList(ByRef ipArray As Variant, ByVal ipRow As Long) As ArrayList
Dim myList As ArrayList
Set myList = New ArrayList
Dim myIndex As Long
For myIndex = LBound(ipArray, 2) To UBound(ipArray, 2)
myList.Add ipArray(ipRow, myIndex)
Next
Set GetRowAsList = myList
End Function
Public Sub Assign(ByRef ipTo As Variant, ByRef ipFrom As Variant)
If VBA.IsObject(ipFrom) Then
Set ipTo = ipFrom
Else
ipTo = ipFrom
End If
End Sub
I did it a little differently:
Sub ColsToRows()
Dim dict As Dictionary
Dim inner As Dictionary
Dim arr() As Variant
Dim arrNotExpand() As Variant
'add headers of columns you don't want to have expanded to array
arrNotExpand = Array("Name")
Dim myRange As Range
'set start of range you want to be converted; vals in first column will be used for keys in main dict
Set myRange = Range("A1").CurrentRegion
Dim Destination As Range
'set start destination range
Set Destination = Range("G1")
'creating main dict
Set dict = New Dictionary
'looping through all cells in first column (ex header)
For x = 2 To myRange.Rows.Count
'define key
dictKey = Cells(x, 1).Value
'check if key exists
If dict.Exists(dictKey) Then
'if exists, get innerKey, add val from each col to its inner dict
For y = 2 To myRange.Columns.Count
innerKey = Cells(1, y).Value
newVal = Cells(x, y).Value
'getting array from key, adding val to it, and reassigning updated array
arr = dict(dictKey)(innerKey)
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = newVal
dict(dictKey)(innerKey) = arr
Next y
Else
'key does not exist, create new inner dict
Set inner = New Dictionary
'add inner dict for each col, and assign first vals
For y = 2 To myRange.Columns.Count
innerKey = Cells(1, y).Value
newVal = Cells(x, y).Value
arr = Array(newVal)
inner.Add innerKey, arr
Next y
'add inner dict to main dict
dict.Add dictKey, inner
End If
Next x
'establish maxCols, i.e. the max length of any array for inner
maxCols = 1
'since we're retrieving the expanded version of arr for each inner, we can just check the first to get the maxCols val
For Each dictKey In dict.Keys
'checking lengthArray
lengthArray = UBound(dict(dictKey)(dict(dictKey).Keys()(1))) + 1
'if it is larger than prev stored val, use new length
If lengthArray > maxCols Then
maxCols = lengthArray
End If
Next dictKey
'convert dict to Destination
'header for keys main dict
Destination = myRange.Cells(1, 1)
'keep track of offset rows
countRow = 0
For Each dictKey In dict.Keys
'keep trach of offset cols
countCol = 0
For Each innerKey In dict(dictKey)
'if so, add the dictKey
If countCol = 0 Then
Destination.Offset(1 + countRow, 0) = dictKey
End If
'if innerKey not in arrNotExpand, we want use full array
If IsError(Application.Match(innerKey, arrNotExpand, 0)) Then
'if we are looking at the first key, also add the headers for each inner dict key
If countRow = 0 Then
For col = 1 To maxCols
'add increment for headers, e.g. "Amount1", "Amount2" etc. (replace necessary for getting rid of whitespace)
Destination.Offset(countRow, 1 + countCol + col - 1) = Replace(innerKey + Str(col), " ", "")
Next col
End If
'get length of arr for specific inner dict
lengthArray = UBound(dict(dictKey)(innerKey)) + 1
'use here for resizing and fill with array
Destination.Offset(1 + countRow, 1 + countCol).Resize(1, lengthArray) = dict(dictKey)(innerKey)
'adjust offset cols
countCol = countCol + maxCols
Else
'only True if the first innerKey is in arrNotExpand
If countRow = 0 Then
Destination.Offset(countRow, 1 + countCol) = innerKey
End If
'no expansion, so use only first val from array
Destination.Offset(1 + countRow, 1 + countCol) = dict(dictKey)(innerKey)(0)
'adjust offset col just by one
countCol = countCol + 1
End If
Next innerKey
'adjust offset row for next dict key
countRow = countRow + 1
Next dictKey
End Sub
Make sure to enter the correct references for Set myRange = Range("A1").CurrentRegion and Set Destination = Range("F1"). Add the headers for columns that you don't want to expand to this array : arrNotExpand = Array("Name"). As is, you'll get the expected output. Let's say you add "Amount" as well, so: arrNotExpand = Array("Amount", "Name"), then you'll get this:
If you add more columns to the range, this works. Just make sure that all your headers are unique (else you'll run into an error with assigning new dict.keys). Let me know if anything is unclear, or if you find a bug.

Getting error in vba subscript out of range for array and for loop

I have the follow code to fill cells in excel one by one and it works the way I want it to but it gives me this error when it runs through the array. How do I fix this error? Thanks
The error is "Subscript out of range. Error: 9"
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
Cells(i, 1) = finalSplit(0)
Cells(i, 2) = finalSplit(1)
Cells(i, 3) = finalSplit(2)
Cells(i, 4) = finalSplit(3)
i = i + 1
s = s + 1
Next
I checked if finalSplit contains enough values like Thomas said and it worked.This is the new code below.
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
If UBound(finalSplit) > 1 Then
Cells(i, 1) = finalSplit(0)
Cells(i, 2) = finalSplit(1)
Cells(i, 3) = finalSplit(2)
Cells(i, 4) = finalSplit(3)
i = i + 1
s = s + 1
End If
Next
As other commenters have pointed out, why not add another control variable?
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
Dim i As Integer, j As Integer, s As Integer
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
For j = 0 To UBound(finalSplit)
Cells(i, j + 1) = finalSplit(j)
Next j
i = i + 1
s = s + 1
Next
Be aware that this can loop more than the 4 times you expect. A lazy way to solve this would be to add If j > 3 Then Exit For before Next j
I tested this with the following code (it works!), as I have no idea what splitString() or finalSplit() is in your case:
Sub test()
Dim finalSplit As Variant
Dim j As Integer
finalSplit = Split("1,2,3,4,5", ",")
For j = 0 To UBound(finalSplit)
Cells(1, j + 1) = finalSplit(j)
If j > 3 Then Exit For
Next j
End Sub
Looping Through Elements of Arrays
An array created by the Split function is always 0-based (even if Option Base 1). Similarly, not quite related, an array created by the Array function is dependent on Option Base unless you use its parent VBA e.g. arr = VBA.Array(1,2,3). Then it is always zero-based.
Looping through the elements of an array (1D array) is done in the following two ways:
For Each...Next
Dim Item As Variant
For Each Item In Arr
Debug.Print Item
Next Item
For...Next
Dim i As Long
For i = LBound(Arr) To Ubound(Arr)
Debug.Print Arr(i)
Next i
Since we have established that Split always produces a zero-based array, in the second example we could use 0 instead of LBound(Arr):
`For...Next`
Dim i As Long
For i = 0 To Ubound(Arr)
Debug.Print Arr(i)
Next i
Option Explicit
Sub DoubleSplit()
Const IniString As String = "A,B,C,D/E,F,G,H/I,J,K/L/M,N,O,P,Q,R"
Dim SplitString() As String: SplitString = Split(IniString, "/")
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
ws.Cells.ClearContents ' remove previous data; clears the whole worksheet
Dim FinalSplit() As String
Dim Item As Variant ' SplitString Control Variable
Dim r As Long ' Worksheet Row Counter
Dim f As Long ' FinalSplit Element Counter
' For Each...Next
For Each Item In SplitString
r = r + 1
FinalSplit = Split(Item, ",")
Debug.Print Join(FinalSplit, ",")
For f = 0 To UBound(FinalSplit)
ws.Cells(r, f + 1).Value = FinalSplit(f)
Next f
Next Item
r = r + 1 ' add an empty row
Dim s As Long ' SplitString Element Counter
' For...Next
For s = 0 To UBound(SplitString)
r = r + 1
FinalSplit = Split(SplitString(s), ",")
Debug.Print Join(FinalSplit, ",")
For f = 0 To UBound(FinalSplit)
ws.Cells(r, f + 1).Value = FinalSplit(f)
Next f
Next s
' Results
' A,B,C,D
' E,F,G,H
' I,J,K
' L
' M,N,O,P,Q,R
'
' A,B,C,D
' E,F,G,H
' I,J,K
' L
' M,N,O,P,Q,R
End Sub

How to remove multiple characters in a string in excel

I have a few thousand rows I would like to clean. I would like to remove all repeated commas and replace them with just one comma. I am using excel. Examples can be scene below
Current Data
Desired Output
,,,,,,,,,,
one,,,,,,two,,,,,three
one, two, three
two,,,,one,,,,,,
two, one
two,,, one,one,two,,,one
two, one, one, two, one
You can apply it to a cell as a user-defined function, and if you have a lot of data, it will be faster to use a procedure.
Sub test()
Dim vDB As Variant
Dim vResult() As Variant
Dim i As Long, r As Long
Dim str As String
vDB = Range("a1", Range("a" & Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vResult(1 To r, 1 To 1)
For i = 1 To r
str = vDB(i, 1)
vResult(i, 1) = myresult(str)
Next i
Range("b1").Resize(r) = vResult
End Sub
Function myresult(str As String)
Dim vR(), vS, v
Dim n As Integer
vS = Split(str, ",")
For Each v In vS
If v <> "" Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = v
End If
Next v
If n Then
myresult = Join(vR, ", ")
Else
myresult = ""
End If
End Function

How to count the total number of specific words in a cell and do the same for other cells as well using VBA?

How do I count the total number of "alt" and "first" that appeared in a cell and do the same for other cells as well while ignoring empty cells in the process? For instance, if a cell has first, first, alt, first, first, first, it should give me firstcounter = 5 (where firstcounter is the total count for first) and altcounter= 1(altcounter is the total count for alt). After that I can use the value of firstcounter and altcounter found to concatenate them into a string as shown in column B in the form of "first-" & firstcounter, "alt-"& altcounter.
Dim ia As Long
Dim lastrow2 As Long
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
lastrow2 = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row
For ia = 2 To lastrow2
Dim arr() As Variant
' Split the string to an array
arr = Split(ws1.Cells(ia, "A"), ",").Value
'what should i do after split
Enter the following into a code module...
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Then in cell B2 enter this formula:
=CountWords(A2)
Now copy it downwards as far as you need.
Update
To use the above function from VBA without entering formulas in the worksheet you can do it like this...
Sub Cena()
Dim i&, v
With [a2:a8]
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Offset(, 1) = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Update #2
In response to your questions in the comments, you can use this variation instead...
Sub Cena()
Dim i&, v
With [a2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Cells = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
In order to make this independent from the words alt and first and whitespaces in the string I would use the following functions
Option Explicit
'Add a reference to Microsoft VBScript Regular Expressions 5.5
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
'Add a reference to Microsoft Scripting Runtime
Function CountWordsA(rg As Range) As String
On Error GoTo EH
Dim dict As Dictionary
Set dict = New Dictionary
Dim vDat As Variant
vDat = RemoveWhiteSpace(rg.Value)
vDat = Split(vDat, ",")
Dim i As Long
For i = LBound(vDat) To UBound(vDat)
If dict.Exists(vDat(i)) Then
dict(vDat(i)) = dict(vDat(i)) + 1
Else
dict.Add vDat(i), 1
End If
Next i
Dim vKey As Variant
ReDim vDat(1 To dict.Count)
i = 1
For Each vKey In dict.Keys
vDat(i) = vKey & "-" & dict(vKey)
i = i + 1
Next vKey
CountWordsA = Join(vDat, ",")
Exit Function
EH:
CountWordsA = ""
End Function
Sub TestIt()
Dim rg As Range
Set rg = Range("A2:A8")
Dim sngCell As Range
For Each sngCell In rg
sngCell.Offset(, 1) = CountWordsA(sngCell)
Next sngCell
End Sub
More about dictionaries and regular expressions
Alternative using Filter() function
This demonstrates the use of the Filter() function to count words via function UBound():
Function CountTerms() (usable also in formulae)
Function CountTerms(ByVal WordList As String, Optional TermList As String = "first,alt", Optional DELIM As String = ",") As String
'Purpose: count found terms in wordlist and return result as list
'[1] assign lists to arrays
Dim words, terms
words = Split(WordList, DELIM): terms = Split(TermList, DELIM)
'[2] count filtered search terms
Dim i As Long
For i = 0 To UBound(terms)
terms(i) = terms(i) & "-" & UBound(Filter(words, terms(i), True, vbTextCompare)) + 1
Next i
'[3] return terms as joined list, e.g. "first-5,alt-1"
CountTerms = Join(terms, ",")
End Function
Example call (due to comment) & help function getRange()
In order to loop over the entire range and replace the original data with the results list:
Sub ExampleCall()
'[1] get range data assigning them to variant temporary array
Dim rng As Range, tmp
Set rng = getRange(Sheet1, tmp) ' << change to sheet's Code(Name)
'[2] loop through array values and get counts
Dim i As Long
For i = 1 To UBound(tmp)
tmp(i, 1) = CountTerms(tmp(i, 1))
Next i
'[3] write to target (here: overwriting due to comment)
rng.Offset(ColumnOffset:=0) = tmp
End Sub
Function getRange(mySheet As Worksheet, tmp) As Range
'Purpose: assign current column A:A data to referenced tmp array
With mySheet
Set getRange = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
tmp = getRange ' assign range data to referenced tmp array
End With
End Function

How to compare two sheets in excel & output similarities AND differences?

I have a current code that compares the first two sheets and then outputs the differences in another. I am now trying to figure out how to also output the similarities into another worksheet.
Here is my current code:
Option Explicit
Sub CompareIt()
Dim ar As Variant
Dim arr As Variant
Dim Var As Variant
Dim v()
Dim i As Long
Dim n As Long
Dim j As Long
Dim str As String
ar = Sheet1.Cells(10, 1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
ReDim v(1 To UBound(ar, 2))
For i = 2 To UBound(ar, 1)
For n = 1 To UBound(ar, 2)
str = str & Chr(2) & ar(i, n)
v(n) = ar(i, n)
Next
.Item(str) = v: str = ""
Next
ar = Sheet2.Cells(10, 1).CurrentRegion.Resize(, UBound(v)).Value
For i = 2 To UBound(ar, 1)
For n = 1 To UBound(ar, 2)
str = str & Chr(2) & ar(i, n)
v(n) = ar(i, n)
Next
If .exists(str) Then
.Item(str) = Empty
Else
.Item(str) = v
End If
str = ""
Next
For Each arr In .keys
If IsEmpty(.Item(arr)) Then .Remove arr
Next
Var = .items: j = .Count
End With
With Sheet3.Range("a10").Resize(, UBound(ar, 2))
.CurrentRegion.ClearContents
.Value = ar
If j > 0 Then
.Offset(1).Resize(j).Value = Application.Transpose(Application.Transpose(Var))
End If
End With
Sheet3.Activate
End Sub
Any ideas?
Since your question is:
Any ideas?
I do have an idea that does rely on:
Your excel license (TEXTJOIN function is available if you have Office 2019, or if you have an Office 365 subscription)
Your data size (If the resulting string exceeds 32767 characters (cell limit), TEXTJOIN returns the #VALUE! error.)
But it's an idea :)
Sheet1 & Sheet2
Run this code:
Sub Test()
Dim Var() As String
With ThisWorkbook.Sheets("Sheet3")
Var() = Split(Evaluate("=TEXTJOIN("","",TRUE,IF(Sheet1!A1:A6=TRANSPOSE(Sheet2!A1:A5),Sheet1!A1:A6,""""))"), ",")
.Cells(1, 1).Resize(UBound(Var) + 1).Value = Application.Transpose(Var)
End With
End Sub
Output on sheet3:
Obviously it's simplified, but you can add variables in the EVALUATE.

Resources