VBA - Transfer Data from one sheet to another

Try this.

Private Sub CommandButton1_Click()
   Dim dict As Object, rCell As Range
    Dim lngLastRow As Long
    
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
        
    With Sheets("Template")
        For Each rCell In .Range("D7:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
            dict.Item(rCell.Value) = Empty
        Next rCell
    End With

    For Each V In dict.Keys()
        With Sheets("Header")
            lngLastRow = .UsedRange.Rows.Count
            .Cells(lngLastRow, 1).End(xlUp).Offset(1, 0).Value = V
            .Cells(lngLastRow, 2).End(xlUp).Offset(1, 0).Value = V
            .Cells(lngLastRow, 3).End(xlUp).Offset(1, 0).Value = "Test"

            .Cells(lngLastRow, 7).End(xlUp).Offset(1, 0).Value = Sheets("Template").Range("E" & Sheets("Template").UsedRange.Rows.Count)
     
        End With
    Next V
End Sub

Select allOpen in new window

Hi Martin, it's been a long time since.

Unfortunately, it just gives me the last record of column D "Template" and the other column does not match


what it should be without talking about the column 3

Please describe in words what should happen after the button is clicked.

After the click:
It should transfer single values that are in column D from Sheet "Template" into Sheet "Header" Column A and B. Then, also take the value from Column "E" of Sheet "Template"  of the same same row, and put this into Sheet "Header" Column "G".

No duplicate in sheet "Header" should be found.

Should any data in either sheet be cleared as the first step in the macro?

Just the sheet "Header" from row 2 going done would be clear before the macro transferred the data. The row one will contained the headers for each columns.
The Sheet "Template" must remained intact.

OK and I assume when you said "Then, also take the value from Column "E" of Sheet "Template"..." that you meant G and not E.

It's Column "E" from sheet "Template"
Goes in Column "G" of sheet "Header"

Oh, of course.

Hi,

This can be easilly solved by taking adventage of a collection instead of a dictionary (since collection keys must be unique), and a Pair class:

First, the Pair class:

    '// Pair class
Option Explicit

Private mFirst As Variant
Private mSecond As Variant

Friend Sub Construct(ByVal First As Variant, ByVal Second As Variant)
    mFirst = First
    mSecond = Second
End Sub

Public Property Get First() As Variant
    First = mFirst
End Property

Public Property Get Second() As Variant
    Second = mSecond
End Property

Select allOpen in new window

Second, a Factory module with an helper function to instanciate a Pair:

    '// Factory module
Option Explicit

Public Function Create_Pair(ByVal First As Variant, ByVal Second As Variant) As Pair
    Set Create_Pair = New Pair
    Create_Pair.Construct First, Second
End Function

Select allOpen in new window

Finally, the event handler attached to your button as well as a second helper function:

Option Explicit

Private Sub CommandButton1_Click()
    Dim Uniques As Collection
    Set Uniques = GetUniques
    
    Dim Wb As Excel.Workbook
    Set Wb = ThisWorkbook
    
    Dim Ws As Excel.Worksheet
    Set Ws = Wb.Worksheets("Header")
    
    Dim Rng As Excel.Range
    Set Rng = Ws.Range("A2")
    
    Dim Pair As Pair
    For Each Pair In Uniques
        Rng.Value = Pair.First
        Rng.Offset(ColumnOffset:=1).Value = Pair.First
        Rng.Offset(ColumnOffset:=6).Value = Pair.Second
        Set Rng = Rng.Offset(RowOffset:=1)
    Next
End Sub

    '// Build a collection of uniques items
Private Function GetUniques() As Collection
    Dim Uniques As Collection
    Set Uniques = New Collection

    Dim Rng As Excel.Range
    For Each Rng In Me.Range("D7:D" & Me.Cells(Me.Rows.Count, "D").End(xlUp).Row)
        Dim Pair As Pair
        Set Pair = Factory.Create_Pair(Rng.Value, Rng.Offset(ColumnOffset:=1).Value)
        On Error Resume Next
            '// attempt to insert a pair in the collection
            '// if it fail, ignore and move to the next
        Uniques.Add Pair, CStr(Pair.First)
        On Error GoTo 0
    Next
    Set GetUniques = Uniques
End Function

Select allOpen in new window

Hi Fabrice, Would you know why i'M getting this below error?

I’m glad I was able to help. It's also nice when I can learn something new, which in this case was a better understanding of dictionaries.

If you expand the “Full Biography" section of my profile you’ll find links to some articles I’ve written that may interest you.

Marty - Microsoft MVP 2009 to 2017
              Experts Exchange Most Valuable Expert (MVE) 2015, 2017
              Experts Exchange Distinguished Expert in Excel 2018
              Experts Exchange Top Expert Visual Basic Classic 2012 to 2020
              Experts Exchange Top Expert VBA 2018 to 2020

Thanks for your help. It was also easy for me to tweak the macro as well to transfer an extra column.

Hi Fabrice, Would you know why i'M getting this below error?

You did not rename the required Pair class module, neither the required Factory module....

Oh! I see. It works. This is interesting. Thanks