transpose and remove duplicates

[rakesh seebaruth]

Hi Guys

I have the following link

https://www.dropbox.com/s/i77n2rc0c5pgfk7/transpose.xlsx?dl=0


Sheet1 is my data table and Sheet2 is the output.

You will notice that there are five Ref Numbers which are the same(TV201801/000380). These Ref numbers are assigned to the name of the persons and his/her role. Same applies to TV201801/000381.

I want vba to do the following for me :

(i) To remove all duplicates in Ref Number Column and keep only one TV201801/000380 .Same applies also for
TV201801/000381.
(ii) To choose at random a seller and a purchaser with their respective Ref Numbers as shown in Sheet2

thanks/regards

rakesh

 

[MickG]

Try this :-
Data sheet1, Results sheet2.

[COLOR="Navy"]Sub[/COLOR] MG05May44
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Dn.Offset(, 2).Value
        [COLOR="Navy"]Case[/COLOR] "Seller": Num = 1
        [COLOR="Navy"]Case[/COLOR] "Purchaser": Num = 2
    [COLOR="Navy"]End[/COLOR] Select

[COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
    ReDim ray(1 To 2)
    ray(Num) = Dn.Offset(, 1).Value
   .Add Dn.Value, ray
[COLOR="Navy"]Else[/COLOR]
    Q = .Item(Dn.Value)
        [COLOR="Navy"]If[/COLOR] Q(1) = "" And Num = 1 [COLOR="Navy"]Then[/COLOR] Q(Num) = Dn.Offset(, 1).Value
        [COLOR="Navy"]If[/COLOR] Q(2) = "" And Num = 2 [COLOR="Navy"]Then[/COLOR] Q(Num) = Dn.Offset(, 1).Value
    .Item(Dn.Value) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim nray(1 To .Count + 1, 1 To 3)
nray(1, 1) = "Ref Numbers": nray(1, 2) = "Seller": nray(1, 3) = "Purchaser"

c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
    nray(c, 1) = K
    nray(c, 2) = .Item(K)(1)
    nray(c, 3) = .Item(K)(2)
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 3)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[rakesh seebaruth]

thanks it's works

 

[MickG]

You're welcome