VBA macro to manipulate data list

[shimon.amar]

Hello dear fellows, how are you today?

My manager gave me a task and I need your help. I need a VBA that will do the follows-

I have a long list of data -

Account	Headline 2	Headline 3	Unit
125123	Asset	NIZ003	BGT003
123511	Asset	DSE003	BGT003
212334	Liability	SDS003	BGT003
125211	Asset	CDE004	BGT004
214122	Liability	DEF004	BGT004

<tbody>
</tbody>

I need a VBA that in each change in column "Unit", it will open 2 rows in between the lines.
In the first row that will open it will take the data from column "headline 2" in the first row before the change and in the second row that opened it will take the data from "Headline 3" from the first row before the change and etc.

The outcome of the example should be like this-

Account	Headline 2	Headline 3	Unit
Asset
	NIZ003
125123	Asset	NIZ003	BGT003
123511	Asset	DSE003	BGT003
212334	Liabiluty	SDS003	BGT003
Asset
	CDE004
125211	Asset	CDE004	BGT004
214122	Libility	DEF004	BGT004

<tbody>
</tbody>

The lines the need to be automatically added are colored in Red.

Thanks in advance for your efforts and the help.

 

[MickG]

Try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG16Aug18
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("D2", Range("D" & 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"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

ReDim Ray(1 To Rng.Count + .Count * 3, 1 To 4)
Ray(1, 1) = "Account": Ray(1, 2) = "Headline 2": Ray(1, 3) = "Headline 3": Ray(1, 4) = "Unit)"
c = 1
 [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    c = c + 1
      Ray(c, 1) = .Item(K)(1).Offset(, -2)
        c = c + 1
          Ray(c, 2) = .Item(K)(1).Offset(, -1)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
        c = c + 1
        Ray(c, 1) = R.Offset(, -3)
        Ray(c, 2) = R.Offset(, -2)
        Ray(c, 3) = R.Offset(, -1)
        Ray(c, 4) = R.Value
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 4)
   .Value = Ray
   .Borders.Weight = 2
   .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick