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 -

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Account[/TD]
[TD]Headline 2[/TD]
[TD]Headline 3[/TD]
[TD]Unit[/TD]
[/TR]
[TR]
[TD]125123[/TD]
[TD]Asset[/TD]
[TD]NIZ003[/TD]
[TD]BGT003[/TD]
[/TR]
[TR]
[TD]123511[/TD]
[TD]Asset[/TD]
[TD]DSE003[/TD]
[TD]BGT003[/TD]
[/TR]
[TR]
[TD]212334[/TD]
[TD]Liability[/TD]
[TD]SDS003[/TD]
[TD]BGT003[/TD]
[/TR]
[TR]
[TD]125211[/TD]
[TD]Asset[/TD]
[TD]CDE004[/TD]
[TD]BGT004[/TD]
[/TR]
[TR]
[TD]214122[/TD]
[TD]Liability[/TD]
[TD]DEF004[/TD]
[TD]BGT004[/TD]
[/TR]
</tbody>[/TABLE]

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-

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Account[/TD]
[TD]Headline 2[/TD]
[TD]Headline 3[/TD]
[TD]Unit[/TD]
[/TR]
[TR]
[TD]Asset[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]NIZ003[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]125123[/TD]
[TD]Asset[/TD]
[TD]NIZ003[/TD]
[TD]BGT003[/TD]
[/TR]
[TR]
[TD]123511[/TD]
[TD]Asset[/TD]
[TD]DSE003[/TD]
[TD]BGT003[/TD]
[/TR]
[TR]
[TD]212334[/TD]
[TD]Liabiluty[/TD]
[TD]SDS003[/TD]
[TD]BGT003[/TD]
[/TR]
[TR]
[TD]Asset[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]CDE004[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]125211[/TD]
[TD]Asset[/TD]
[TD]CDE004[/TD]
[TD]BGT004[/TD]
[/TR]
[TR]
[TD]214122[/TD]
[TD]Libility[/TD]
[TD]DEF004[/TD]
[TD]BGT004[/TD]
[/TR]
</tbody>[/TABLE]

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