Searching collections - vba
I'm working with a rather large dataset (>100,000 rows) and trying to compare two lists to figure out which items in the new list are not already in the master list. In other words I want to find the new unique items.
I have some VBA code that uses vlookup and arrays that works, but bombs out when the arrays get too big (~70,000). So I've turned to collections. However I'm having difficulty searching the collections using vlookup or match.
Sub find_uniqueIDs()
Dim a As Long
Dim n As Long
Dim m As Variant
Dim oldnum As Long
Dim oldIDs As Variant
Dim oldcoll As New Collection
Dim newnum As Long
Dim newIDs As Variant
Dim newcoll As New Collection
oldnum = 75000
oldIDs = Range("A1", Range("A" & oldnum))
newnum = 45000 + 3
newIDs = Range("G3", Range("G" & newnum))
'Using arrays to search, but bombs out when oldnum or newnum are ~70000
For n = 1 To newnum - 3
m = Application.VLookup(newIDs(n, 1), oldIDs, 1, False)
If IsError(m) Then Range("E100000").End(xlUp).Offset(1, 0) = newIDs(n, 1)
Next n
'Using collections to search
For n = 1 To oldnum
On Error Resume Next
oldcoll.Add oldIDs(n, 1)
On Error GoTo 0
Next n
For m = 1 To newnum
On Error Resume Next
newcoll.Add newIDs(m, 1)
On Error GoTo 0
Next m
'This bit of code doesn't work
For a = 1 To newcoll.Count
If Application.VLookup(newcoll(a), oldcoll, 1, False) = "#N/A" Then _
Range("E100000").End(xlUp).Offset(1, 0) = newcoll(a)
Next a
End Sub
Any ideas how I can determine whether a particular item is in the master list using collections?
Here is a short sub demonstrating some of the scripting dictionary methods.
Sub list_New_Unique()
Dim dMASTER As Object, dNEW As Object, k As Variant
Dim v As Long, vVALs() As Variant, vNEWs() As Variant
Debug.Print "Start: " & Timer
Set dMASTER = CreateObject("Scripting.Dictionary")
Set dNEW = CreateObject("Scripting.Dictionary")
dMASTER.comparemode = vbTextCompare
dNEW.comparemode = vbTextCompare
With Worksheets("Sheet7")
vVALs = .Range("A2:A100000").Value2
vNEWs = .Range("C2:C100000").Value2
End With
'populate the dMASTER values
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
dMASTER.Add Key:=vVALs(v, 1), Item:=vVALs(v, 1)
Next v
'only populate dNEW with items not found in dMASTER
For v = LBound(vNEWs, 1) To UBound(vNEWs, 1)
If Not dMASTER.exists(vNEWs(v, 1)) Then
If Not dNEW.exists(vNEWs(v, 1)) Then _
dNEW.Add Key:=vNEWs(v, 1), Item:=vNEWs(v, 1)
End If
Next v
Debug.Print dNEW.Count
For Each k In dNEW.keys
'Debug.Print k
Next k
Debug.Print "End: " & Timer
dNEW.RemoveAll: Set dNEW = Nothing
dMASTER.RemoveAll: Set dMASTER = Nothing
End Sub
With 99,999 unique entries in A2:A100000 and 89747 random entries in C2:C89747, this found 70,087 unique new entries not found in A2:A100000 in 9.87 seconds.
I would do it like this:
Sub test()
Dim newRow As Long, oldRow As Long
Dim x As Long, Dim y As Long
Dim checker As Boolean
With ActiveSheet
newRow = .Cells(.Rows.Count,7).End(xlUp).Row
oldRow = .Cells(.Rows.Count,1).End(xlUp).Row
checker = True
for y = 1 To oldRow
for x = 1 To newRow
If .Cells(y,1).Value = .Cells(x,7).Value Then
checker = False
Exit For
End If
Next
If checker Then
Range("E10000").End(xlUp).Offset(1,0).Value = .Cells(y,1).Value
End If
checker = True
Next
End With
End Sub
VLookup is a worksheet function, not a regular VBA function, thus it's for searching in Ranges, not Collections.
Syntax: VLOOKUP (lookup_value, table_array, col_index_num, [range_lookup])
[...]
table_array (required): the range of cells in which the VLOOKUP will search for the lookup_value and the return value.
In order to search in other VBA data structures like arrays, collections etc you'll have to figure out some other way and maybe implement it manually.
While #Jeeped suggestion of a Scripting.Dictionary object might be the best one, you could also try using the Filter() function applied to your array.
Related
Format cells with the same values split by a delimiter, but a different order in VBA
I am a VBA beginner, who cannot seem to find a solution to what seemed to be a very easy comparison to me at first. Basically, I have 2 columns where the values in the cells are split by a delimiter, however, not in the same order. eg. Range("A1").value = "1234|5678" Range("B1").value = "5678|1234" B1 should then be highlighted as a duplicate I am searching for some vba code which I can use to loop through the used range's in Columns A & B, to compare and highlight cells in column B that are duplicated, as per example above. Apologies if I missed any similar questions asked and answered previously, I have indeed conducted a search but perhaps my search criteria may have been out of bounds, and I simply did not come across the VBA solution. Regards, Enjay
Based on the little information given you could try the following code Sub Highlight() Const DELIMITER = "|" Dim rg As Range Dim a As Variant Dim b As Variant Dim sngCell As Range Set rg = Range("A1:A3") For Each sngCell In rg a = Split(sngCell.Value2, DELIMITER) b = Split(sngCell.Offset(, 1).Value2, DELIMITER) If isEqual(a, b) Then With sngCell.Offset(, 1).Interior .ThemeColor = xlThemeColorAccent6 End With End If Next sngCell End Sub with the following functions Function isEqual(a As Variant, b As Variant) As Boolean a = BubbleSort(a) b = BubbleSort(b) isEqual = True Dim i As Long For i = LBound(a) To UBound(a) If a(i) <> b(i) Then isEqual = False Exit For End If Next i End Function Function BubbleSort(ByRef strArray As Variant) As Variant 'sortieren von String Array 'eindimensionale Array 'Bubble-Sortier-Verfahren Dim z As Long Dim i As Long Dim strWert As Variant For z = UBound(strArray) - 1 To LBound(strArray) Step -1 For i = LBound(strArray) To z If LCase(strArray(i)) > LCase(strArray(i + 1)) Then strWert = strArray(i) strArray(i) = strArray(i + 1) strArray(i + 1) = strWert End If Next i Next z BubbleSort = strArray End Function
This will answer your question as-is. If the solution needs to be adjusted, I trust that you can fix it :) This uses StrComp to (in memory only) re-order the two string parts so that it can easily detect duplicate values. Option Explicit Sub DuplicateCheck() Dim delimiter As String delimiter = "|" Dim lastCol As Long lastCol = Cells(1, Columns.count).End(xlToLeft).Column Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Dim i As Long For i = 1 To lastCol Dim theSplit As Variant theSplit = Split(Cells(1, i), delimiter) Dim temp As String If StrComp(theSplit(0), theSplit(1), vbTextCompare) = 1 Then temp = theSplit(1) theSplit(1) = theSplit(0) theSplit(0) = temp End If temp = theSplit(0) & delimiter & theSplit(1) If Not dict.exists(temp) Then dict.Add (temp), 1 Else Cells(1, i).Interior.color = 65535 End If Next i End Sub
Comparing two Excel worksheet and display new data in a new worksheet
I looked for the answer of my problem in all topics discussed on this platform such as Compare two Sheet and find differences, Macro to compare two worksheets & highlights differences and so on ... but I did not found what I was looking for. My question is ; is there a possibility to compare two excel worksheets with a different layout as below? I'm willing to compare an historical worksheets versus a new worksheets and display in a third worksheet what was on the new worksheet that does not exist in the historical e.g : I hope you will understand my question and be able to help me on this topic. I already have a code which compare two worksheet and show the difference but it's not enough for my problem. 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("a1").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 End Sub Thanks in advance
VBA to delete rows based on cell value
I am trying to do the following : VBA to lookup a value from a particular cell Match these values in a particular column in specified sheets Delete all rows from the sheet if the value do not match I have tried the following - the code doesn't seem to function Sub Delete() Dim List As Variant Dim LR As Long Dim r As Long List = Worksheets("Sheet1").Cells(28, "C").Value LR = Range("E" & Rows.Count).End(xlUp).Row For r = LR To 1 Step -1 If IsError(Application.Match(Range("E" & r).Value, List, False)) Then Worksheets("Sheet2").Range("A1:AA36429").Rows(r).Delete End If Next r End Sub
Try this: Sub Delete() Dim i As Integer Dim LR As Long Dim List As Variant LR = Range("E" & Rows.Count).End(xlUp).Row List = Worksheets("Sheet1").Cells(28, "C").Value For i = 1 To LR If Cells(i, "E").Value = List Then Worksheets("Sheet1").Rows(i).Delete End If Next i End Sub
I think you have a few ways of going about this, but the quickest way I know of is to use MATCH to compare values in a range to values in an array. Please note that this has a limit to 4000 or so values to compare before it fails. For your purposes, I think the following will work: Sub test1() Dim x As Long Dim array1() As Variant Dim array2() As Variant array1 = Array("ABC", "XYX") array2 = Range("A1:A2") If IsNumeric(Application.Match(Range("A1").Value, array1, 0)) Then x = 1 ElseIf IsNumeric(Application.Match(Range("A1").Value, array2, 0)) Then x = IsNumeric(Application.Match(Range("A1").Value, array2, 0)) End If 'If x is not found in these arrays, x will be 0. MsgBox x End Sub Another similar way is the following: Sub test2() Dim array1() As Variant Dim FilterArray() As String Dim x As Variant x = Range("A1").Value array1 = Array("ABC", "RANDOM", "VBA") FilterArray = Filter(SourceArray:=array1, _ Match:=strText, _ Include:=True, _ Compare:=vbTextCompare) If UBound(FindOutArray) = -1 Then MsgBox "No, Array doesn't contain this item - " & x Else MsgBox "Yes, Array contains this item - " & x End If End Sub So if we were to incorporate that all together (and I tested this btw): Sub Delete() Dim i As Integer Dim LR As Long Dim List() As Variant Dim x As Long LR = Range("E" & Rows.count).End(xlUp).Row List = Worksheets("Sheet1").Range("A1:A2").Value For i = 1 To LR If IsNumeric(Application.Match(Cells(i, "E").Value, List, 0)) Then Worksheets("Sheet1").Cells(i, "E").Value = "" End If Next i Worksheets("Sheet1").Columns("E").SpecialCells(xlCellTypeBlanks).Cells.Delete End Sub This will set the cells that have values that are found in the array to blanks. Once the loop is finished, then the blank cells are deleted. If you want to shift the entire rows up, then use this as the last line instead: Worksheets("Sheet1").Columns("E").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
VBA to extract names from a list at random isn't working
I want to randomly extract 280 names from a list (dynamic range) of thousands of authors, then concatenate them into 1 string with each name separated by OR. So far I'm stuck at the first part. When I run the following code, nothing happens. Can anyone explain why? Thanks. Sub Authors() Dim InputRange As Range Dim AuthorCount As Long Dim AuthorRange As Excel.Range Set InputRange = Range("A:A") AuthorCount = Application.WorksheetFunction.CountA(InputRange) - 1 Set AuthorRange = ThisWorkbook.Worksheets("Sheet").Range("A2:A" & AuthorCount) Const nItemsToPick As Long = 280 Dim Authorlist As Variant Dim i As Long ReDim Authorlist(1 To nItemsToPick) For i = 1 To nItemsToPick Authorlist(i) = AuthorRange.Cells(Int(AuthorCount * Rnd + 1), 1) Next i End Sub
Using the below code Sub PickSample(intSampleSize As Integer, intPicks As Integer) Dim arr() As String Dim intCounter As Integer ReDim arr(intPicks) For intCounter = 0 To UBound(arr) arr(intCounter) = CStr(Int((intSampleSize - (i - 1)) * Rnd + 1) + (i - 1)) Next intCounter Debug.Print Join(arr(), ",") End Sub I ran this on the following, PickSample(10,5) and got the following, showing the duplicate possibilities, this will become less as the difference between picks and samples increases. 9,9,6,10,10,2 5,3,6,7,2,3 10,4,5,8,0,6 9,8,4,10,9,0 0,8,8,7,0,4 7,5,6,3,3,8 If your selection is 280, but the data set is only 300, dupes still arise PickSample 300,280 228,**92**,248,216,269,66,**107**,166,**107**,61,174,189,41,18,190,252,192,127,56,149,292,231,114,145,164,202,11,194,270,102,35,128,232,**107**,124,225,131,216,152,52,83,26,294,85,186,**92**,256,96,239,52,90,21,148,136,179,9,95,40,98,228,188,290,249,166,182,57,271,95,180,179,230,215,206,228,77,165,153,170,84,125,105,292,156,175,139,9,113,41,196,46,59,112,28,185,211,132,126,101,210,64,13,266,13,138,222,227,247,63,141,261,249,123,139,105,75,242,163,162,188,26,214,77,17,82,289,98,194,109,111,98,64,63,127,185,72,206,177,181,23,13,46,74,120,175,86,251,270,158,116,0,75,49,194,295,93,72,264,39,171,182,183,208,255,29,118,247,80,204,119,251,130,251,65,220,270,65,295,290,262,157,195,137,47,193,184,257,110,15,152,16,112,135,89,291,3,195,184,160,8,215,94,295,87,109,96,106,70,178,211,80,173,173,298,280,75,243,231,122,189,148,150,40,291,53,177,205,32,195,222,234,129,24,150,172,17,124,35,43,94,298,181,82,125,141,19,137,131,284,82,52,152,103,154,119,78,20,192,109,164,265,127,178,114,17,32,43,43,228,79,41,12,208,254,155,240,296,157,20,188,99,83 4,50,49,153,122,31,83,193,255,149,56,269,112,97,232,65,134,71,264,183,112,117,259,176,280,155,99,261,77,78,53,104,0,223,253,83,211,121,244,223,131,23,123,102,213,93,240,45,178,287,73,282,34,296,190,180,271,173,73,258,22,132,228,73,113,119,158,81,174,63,23,269,33,196,271,69,285,254,132,148,231,251,115,58,98,124,45,186,29,61,208,151,55,298,141,1,128,86,226,268,247,53,32,3,45,113,56,294,262,175,219,43,77,8,249,235,238,100,135,167,241,169,61,62,109,172,103,158,128,172,15,164,62,289,280,298,252,123,242,297,77,52,209,5,102,208,33,33,87,120,168,93,88,243,93,113,120,253,123,218,198,122,286,194,155,67,175,225,137,272,85,200,267,84,110,4,88,296,229,174,182,80,152,238,258,28,163,125,22,135,210,150,122,284,296,178,160,185,26,55,85,5,45,126,165,168,235,12,122,17,93,181,155,179,99,273,231,173,129,220,49,17,73,228,286,103,205,238,10,239,145,62,181,273,284,196,4,199,290,2,287,22,88,175,243,12,16,169,94,124,153,220,135,97,22,123,172,229,174,196,243,125,239,217,208,219,57,232,21,74,286,246,66,55,71,278,77,77,215,200,232 209,294,73,160,32,300,203,4,173,30,31,240,85,13,89,114,90,285,294,120,83,48,49,194,123,124,214,98,190,62,55,175,24,137,272,78,236,114,87,276,190,188,128,29,168,209,275,251,6,163,275,129,204,151,154,139,106,121,81,16,73,294,18,117,109,147,46,142,77,189,163,47,282,197,152,117,32,235,138,226,179,250,5,63,22,31,99,38,0,161,197,163,249,24,57,204,136,107,45,212,279,159,26,228,120,139,148,62,99,28,177,51,279,29,133,82,262,225,82,202,77,27,9,97,237,89,70,144,76,102,13,145,62,260,177,227,279,99,163,24,190,123,289,34,277,186,104,44,144,66,299,39,8,103,164,277,162,122,255,248,202,217,300,102,149,124,209,53,127,163,245,162,128,153,68,186,147,204,266,111,91,88,45,159,67,175,109,263,143,57,205,224,184,235,48,243,60,287,19,18,238,114,139,35,34,52,14,215,160,168,65,140,224,226,120,271,224,26,191,214,4,129,120,82,296,241,209,125,221,83,107,130,284,36,194,104,31,55,23,130,288,163,148,292,65,114,119,84,151,41,155,290,167,273,197,132,208,19,227,210,149,46,67,98,236,15,155,227,241,97,292,242,203,272,263,125,37,287,239,209,120 Using a dictionary to handle the dupes, using this code Sub PickSample(intSampleSize As Integer, intPicks As Integer) Dim dicPicked As New Scripting.Dictionary Dim arr() As String Dim intCounter As Integer Dim intPicked As Integer ReDim arr(intPicks) For intCounter = 0 To UBound(arr) RetryPick: intPicked = CStr(Int((intSampleSize - (i - 1)) * Rnd + 1) + (i - 1)) If dicPicked.Exists(CStr(intPicked)) Then GoTo RetryPick Else dicPicked.Add CStr(intPicked), 1 arr(intCounter) = intPicked End If Next intCounter Debug.Print Join(arr(), ",") dicPicked.RemoveAll Set dicPicked = Nothing End Sub Gives results, hopefully dupe free PickSample 300,280 203,125,69,114,26,208,39,219,36,174,220,113,24,74,104,282,128,112,223,205,200,147,44,143,152,162,157,300,70,54,108,177,13,276,153,91,7,168,89,145,127,12,16,257,187,229,61,213,117,214,254,171,59,242,23,51,224,52,185,165,193,189,21,296,63,173,160,280,190,232,235,141,256,56,87,98,32,5,267,195,77,120,197,82,288,68,57,136,132,182,122,15,47,48,261,96,110,258,49,105,155,86,186,97,225,80,264,140,11,46,199,230,275,19,34,83,222,66,116,294,298,259,292,271,272,84,115,101,124,43,183,71,289,291,25,188,55,158,150,216,243,92,58,0,290,148,255,149,250,167,27,233,228,265,9,299,65,283,62,88,207,240,109,179,161,178,268,278,175,139,237,234,169,297,269,281,184,262,270,164,202,279,253,295,196,212,8,274,159,75,172,163,130,38,154,73,99,247,249,263,273,67,40,20,221,138,14,33,218,286,227,251,94,166,209,156,211,37,137,90,131,111,107,2,215,85,146,100,293,204,231,285,79,53,126,60,239,260,248,78,4,217,29,64,121,226,201,210,45,206,134,17,1,192,246,3,35,191,236,93,28,41,244,287,129,277,142,118,6,81,18,135,181,241,180,103,50,252,31,95,30 44,278,132,10,232,56,146,193,284,276,236,155,79,117,102,61,119,200,229,131,138,133,235,173,204,34,7,98,3,202,167,143,130,30,126,206,13,262,221,166,174,298,111,116,39,288,263,76,47,170,89,268,154,253,52,91,217,148,12,22,83,33,77,264,85,214,55,127,279,251,101,86,230,35,172,59,198,62,286,296,220,29,191,242,271,5,54,84,297,158,38,270,231,107,95,110,57,129,9,273,53,269,68,4,234,228,211,207,70,153,151,194,179,128,169,63,142,109,145,58,186,24,245,60,87,0,17,246,225,222,218,184,258,26,161,226,247,31,144,178,223,122,88,124,137,210,293,94,99,213,190,281,80,72,104,40,6,123,290,259,254,45,78,66,227,289,261,141,65,135,8,274,69,257,203,168,196,42,248,67,73,125,37,11,287,181,92,291,238,108,212,1,118,28,216,244,164,249,240,150,46,74,277,36,189,188,255,224,195,260,15,175,267,280,49,180,27,165,50,113,243,201,237,149,205,156,199,292,136,48,71,75,285,41,81,239,209,185,266,160,176,152,171,163,100,2,32,183,16,97,19,294,187,20,282,272,157,182,121,140,106,112,265,295,51,21,256,64,241,114,162,90,252,115,25,82,103,23,299,120,197 57,241,105,1,247,289,284,72,89,68,101,225,295,242,290,5,291,217,267,87,62,80,24,106,103,38,285,197,286,300,151,222,219,254,201,113,195,245,243,15,179,98,145,192,74,118,142,109,70,58,11,4,154,277,129,115,250,202,293,163,181,168,288,268,281,112,79,49,60,175,236,23,266,186,59,167,190,187,41,228,174,157,48,231,165,253,227,171,66,176,135,238,120,258,19,110,194,164,131,296,91,206,159,255,8,189,124,148,114,13,75,121,95,272,119,214,50,117,279,213,205,133,96,196,137,173,246,218,233,77,27,264,141,184,193,263,102,83,244,210,78,127,36,63,188,42,0,152,198,271,169,298,207,111,3,158,182,282,30,226,199,17,273,297,191,166,46,144,252,55,25,26,200,86,162,237,211,299,212,287,161,12,40,45,69,216,54,125,71,47,132,93,22,20,76,126,51,262,107,229,234,257,2,39,278,235,84,37,280,208,153,251,67,136,104,28,221,149,248,276,170,140,14,269,180,16,108,34,94,43,92,52,204,65,134,85,183,7,146,143,97,270,64,259,139,160,260,223,32,81,177,33,178,185,90,292,9,232,209,265,10,88,283,147,123,99,261,240,6,138,274,122,61,203,249,155,256,44,294,116,35
this function picks nItemsToPick random elements up from arr array and returns them into an array: Function PickNRandomElementsFromArray(arr As Variant, nItemsToPick As Long) As Variant Dim arrSize As Long Dim i As Long, iPick As Long Dim temp As String arrSize = UBound(arr) '<--| count the values as the array size If nItemsToPick > arrSize Then nItemsToPick = arrSize '<--| the items to be picked cannot exceed array size For i = 1 To nItemsToPick iPick = Int((arrSize - (i - 1)) * Rnd + 1) + (i - 1) '<--| pick a random number between 'i' and 'arrSize' ' swap array elements in slots 'i' and 'iPick' temp = arr(iPick) arr(iPick) = arr(i) arr(i) = temp Next i ReDim Preserve arr(1 To nItemsToPick) '<--| resize the array to first picked items PickNRandomElementsFromArray = arr '<--| return the array End Function which you can exploit as follows: Option Explicit Sub Authors() Dim Authors As Variant, AuthorsList As Variant With ThisWorkbook.Worksheets("Sheet") '<--| reference your relevant worksheet Authors = Application.Transpose(.Range("A2", .Cells(.rows.count, 1).End(xlUp)).Value) '<--| fill 'Authors' array with its column "A" values from row 2 down to its last not empty one AuthorsList = PickNRandomElementsFromArray(Authors, 280) '<--| fill 'AuthorsList' array with a selection of 280 random elements of 'Authors' .Range("B1").Value = Join(AuthorsList, " OR ") '<--| fill cell "B1" with a string build by concatenating 'AuthorsList' values delimited with " OR " End With End Sub that can be quite contracted (and made as much less readable) to: Sub Authors() With ThisWorkbook.Worksheets("Sheet") '<--| reference your relevant worksheet .Range("B1").Value = Join(PickNRandomElementsFromArray(Application.Transpose(.Range("A2", .Cells(.rows.count, 1).End(xlUp)).Value), 280), " OR ") End With End Sub
From your comments, you seem to want to concatenate the array of strings, then put it back into excel. This, put just before the End Sub, will put it into cell B1 for example: ThisWorkbook.Worksheets("Sheet1").Range("B1").Value = Join(Authorlist, "OR")
Compare two columns and print the same value
I am trying to compare two columns and if any similar value is there then I want to print that value in a third column. My code is like this: Sub compare() Dim arr1 As Range Dim arr2 As Range Set arr1 = Range("A1:A6") Set arr2 = Range("B1:B6") For Each x In arr1 For Each y In arr2 If x = y Then Cells(C1).Value = 0 End If Next y Next x End Sub I am seeing: Run Time error 1004 Application-defined or object defined error
It is tricky to use For Each when working with an array as you don't know where is in your array the data you are trying to work with. And furthermore, it'll only create duplicate values and you won't be able to interact with your array directly. Plus, as your loops were sets, you would compare each cell in the first array to each one in the second array. You only need a common factor to loop on. I added a few tests to avoid some basic issues : Sub compare() Dim arr1 As Range, _ arr2 As Range, _ Ws As Worksheet With Ws Set arr1 = .Range("A1:A6") Set arr2 = .Range("B1:B6") If arr1.Columns.Count > 1 Or arr2.Columns.Count > 1 Then MsgBox "Too many columns for this simple compare", vbCritical + vbOKOnly Exit Sub Else If arr1.Rows.Count <> arr2.Rows.Count Or arr1.Cells(1, 1).Row <> arr2.Cells(1, 1).Row Then MsgBox "The ranges don't have the same amout of lines or don't start at the same line", vbCritical + vbOKOnly Exit Sub Else For i = 1 To arr1.Rows.Count If arr1.Cells(i, 1) <> arr2.Cells(i, 1) Then Else .Cells(arr1.Cells(1, 1).Row + 1, _ Max(arr1.Cells(1, 1).Columns, arr2.Cells(1, 1).Column)) _ .Offset(0, 1).Value = arr1.Cells(i, 1) End If Next i End If End If End With End Sub
The short answer is that you need to specify Row and Column when using Cells. The column is 3 for column C so the code to display the matching values should have looked something like this:- Sub compare() Dim arr1 As Range Dim arr2 As Range Dim count As Integer Set arr1 = Range("A1:A6") Set arr2 = Range("B1:B6") For Each x In arr1 For Each y In arr2 If x = y Then count = count + 1 Cells(count, 3) = x End If Next y Next x End Sub
Below one easy way, define one array with one range with 3 columns (two to compare and the 3th to write result) Sub compare() Dim Arr() As Variant Arr = Range("A1:C6") Dim R As Long For R = 1 To UBound(Arr, 1) If Arr(R, 1) = Arr(R, 2) Then Arr(R, 3) = 0 'or the value of 1th column like arr(r,1) End If Next R Range("A1:C6") = Arr End Sub