Copy corresponding row VBA

Question

I'm using a VBA to copy all the unique values from one sheet to another sheet. My VBA looks like this:

Sub UniqueListSample()

Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")


lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row


On Error Resume Next
For i = 1 To lastrow
    If Len(Sheet1.Cells(i, "B")) <> 0 Then
        dictionary.Add shee.Cells(i, "B").Value, 1
    End If
Next

Sheet3.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)

Application.ScreenUpdating = True

End Sub

This takes all the unique values from Sheet 1 column B and moves them to sheet 3 column A. What I'm now trying to add is a function that takes the same rows from column C in sheet 1 and paste them into sheet 3 column B.

Is there an easy way to add this to the existing VBA?

Answer 1

please check this:

Option Explicit

Sub UniqueListSample()

Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")



lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row


On Error Resume Next
For i = 1 To lastrow
    If Len(Sheet1.Cells(i, "B")) <> 0 Then
        dictionary.Add shee.Cells(i, "B").Value, shee.Cells(i, "c").Value
    End If
Next

With Sheet3

.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)


For i = 1 To dictionary.Count

.Cells(i + 2, 2) = dictionary(Sheet3.Cells(i + 2, 1).Value)


Next

End With

Application.ScreenUpdating = True

End Sub

Answer 2

If you just want one column you can utilise the Item. I prefer to avoid the "On Error" statement - the method below will not error if the same key is used (it will just overwrite).

Sub UniqueListSample()

Application.ScreenUpdating = False

Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet

Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row

With dictionary
    For i = 1 To lastrow
        If Len(Sheet1.Cells(i, "B")) <> 0 Then
            If Not (.Exists(shee.Cells(i, "B").Value)) Then
                .Item(shee.Cells(i, "B").Value) = shee.Cells(i, "C").Value
            End If
        End If
    Next
    Sheet3.Range("A3").Resize(.Count).Value = Application.Transpose(.keys)
    Sheet3.Range("B3").Resize(.Count).Value = Application.Transpose(.items)
End With

Application.ScreenUpdating = True

End Sub