VBA to copy values based on identical text strings in cells and remove duplicates

[smide]

In Sheet1 (starting from row3, A-X columns) I have a data summary (product's mark and product's prices) and Sheet2 is only for the raw data.

Product's mark is characteristic which contains one to six letters (always to the left of price).

I need a Macro to copy/append data from Sheet2 to Sheet1 in an appropriate column (based on identical products columns). // something like hlookup function in macro
Also, I need to remove (if there are) duplicates based on mark columns (cells which already contains the same marks as marks in Sheet1).

Example.

Sheet1 (before update)

	A	B	C	D	E	F	...
1
2
3		Product1		Product5		Product4
4	a	13	b	21	s	11
5	b	8	f	16	pq	31
6	c	12			rd	11
7					w	9

<tbody>
</tbody>

Sheet2 (obtained new "raw" data)

	A	B	C	D	E	F	...
1
2
3		Product4		Product1		Product5
4	w	12	b	10	f	18
5	d	34	c	13	g	31
6			e	28
8		....		....		....

<tbody>
</tbody>

Sheet1 (after update/append from Sheet2, with removed duplicates/same dates)

	A	B	C	D	E	F	...
1
2
3		Product1		Product5		Product4
4	a	13	b	21	s	11
5	b	8	f	16	pq	31
6	c	12	g	31	rd	11
7	e	28			w	9
8		....		.....	d	34
9						....

<tbody>
</tbody>

 

[MickG]

Try this For Update of sheet1 from sheet2.
NB:- Run code from sheet1

[COLOR="Navy"]Sub[/COLOR] MG20Aug39
[COLOR="Navy"]Dim[/COLOR] cRng [COLOR="Navy"]As[/COLOR] Range, cDn [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range, Dic [COLOR="Navy"]As[/COLOR] Object, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] cRng2 [COLOR="Navy"]As[/COLOR] Range, cDn2 [COLOR="Navy"]As[/COLOR] Range, Dn2 [COLOR="Navy"]As[/COLOR] Range, Rng2 [COLOR="Navy"]As[/COLOR] Range, temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] cRng = Range(Range("A3"), Cells(3, Columns.Count).End(xlToLeft))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] cDn [COLOR="Navy"]In[/COLOR] cRng
    c = 0
    [COLOR="Navy"]Dim[/COLOR] ray()
     [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
    [COLOR="Navy"]If[/COLOR] Len(cDn.Value) [COLOR="Navy"]Then[/COLOR]
        temp = cDn.Value
         [COLOR="Navy"]Set[/COLOR] Rng = Range(Cells(4, cDn.Column - 1), Cells(Rows.Count, cDn.Column - 1).End(xlUp))
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
                [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                    c = c + 1
                    ReDim Preserve ray(1 To 2, 1 To c)
                    ray(1, c) = Dn.Value: ray(2, c) = Dn.Offset(, 1)
                    Dic.Add (Dn.Value), Nothing
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]End[/COLOR] If

[COLOR="Navy"]If[/COLOR] Dic.Count <> 0 [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
[COLOR="Navy"]Set[/COLOR] cRng2 = .Range(.Range("A3"), .Cells(3, .Columns.Count).End(xlToLeft))

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] cDn2 [COLOR="Navy"]In[/COLOR] cRng2
    [COLOR="Navy"]If[/COLOR] Len(cDn2.Value) And cDn2.Value = temp [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Rng2 = .Range(.Cells(4, cDn2.Column - 1), .Cells(Rows.Count, cDn2.Column - 1).End(xlUp))
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn2 [COLOR="Navy"]In[/COLOR] Rng2
            [COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn2.Value) [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            ReDim Preserve ray(1 To 2, 1 To c)
            ray(1, c) = Dn2.Value: ray(2, c) = Dn2.Offset(, 1)
            Dic.Add (Dn2.Value), Nothing
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dn2
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] cDn2
[COLOR="Navy"]With[/COLOR] Cells(4, cDn.Column - 1).Resize(c, 2)
    .Value = Application.Transpose(ray)
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] cDn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[smide]

Try this For Update of sheet1 from sheet2.
NB:- Run code from sheet1

Real masterpiece, works perfectly!
Thank you so much Mick.

 

[MickG]

You're welcome