We help IT Professionals succeed at work.

modification to Rgonzo's VBA earlier post

Flora Edwards
on
I had this question after viewing Vba to search in column B and if unique value is just one then return it to cell A1 of sheet1.


this code

gives error on .  if there one unqiue value in column B starting from B2 then it should return that unique value in Cell A1 of Sheet1

currenty it gives error.  runtime 13 sh1.Range("A1").Resize(UBound(aDict) + 1) = Application.Transpose(aDict)

Sub macro2()
Set objDict = CreateObject("Scripting.Dictionary")
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
Set Rng = Range(sh2.Range("B2"), sh2.Range("B" & Rows.Count).End(xlUp))
For Each c In Rng
    If WorksheetFunction.CountIf(Rng, c.Value) = 1 Then
        objDict.Add c.Value, c.Value
    End If
Next

aDict = objDict.Items
sh1.Range("A1").Resize(UBound(aDict) + 1) = Application.Transpose(aDict)
End Sub

Open in new window

Comment
Watch Question

CERTIFIED EXPERT
Top Expert 2016

Commented:
Hi,

pls try
Sub macro()
Set objDict = CreateObject("Scripting.Dictionary")
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
Set Rng = Range(sh2.Range("B2"), sh2.Range("B" & Rows.Count).End(xlUp))
For Each c In Rng
    If WorksheetFunction.CountIf(Rng, c.Value) = 1 Then
        objDict.Add c.Value, c.Value
    End If
Next
If objDict.Count > 1 Then
aDict = objDict.items
sh1.Range("A1").Resize(UBound(aDict) + 1) = Application.Transpose(aDict)
Else
aDict = objDict.items
sh1.Range("A1").Value = aDict(0)
End If
End Sub

Open in new window

Regards
Flora EdwardsMedicine

Author

Commented:
getting error.

EE.png
Flora EdwardsMedicine

Author

Commented:
subscript out of range.  while my sheet(1) exist.
CERTIFIED EXPERT
Top Expert 2016

Commented:
Could you send a dummy?
Flora EdwardsMedicine

Author

Commented:
please see attached two dummy file.

one of the file is where column B only has one unique string

second example is where COlumn B has multiple unique string
Example-with-Multiple-Unique-value.xlsb
Example-with-One-Unique-value.xlsb
CERTIFIED EXPERT
Top Expert 2016
Commented:
then try
Sub macro()
Set objDict = CreateObject("Scripting.Dictionary")
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
For Each c In Range(sh2.Range("B2"), sh2.Range("B" & Rows.Count).End(xlUp))
    If Not objDict.Exists(c.Value) Then objDict.Add c.Value, c.Value
Next

aDict = objDict.Items
sh1.Range("A1").Resize(UBound(aDict) + 1) = Application.Transpose(aDict)
End Sub

Open in new window

Flora EdwardsMedicine

Author

Commented:
thanks very much. i love the best of use of dictionary script you have used to solve the problem. it is  very fast.

Explore More ContentExplore courses, solutions, and other research materials related to this topic.