Code to restructure the rows

[scorleo]

Hello All,

I have never done programming in VB so this is fairly new, had done some PB programming more than 20 years ago but can't remember anything . I exhausted in-built sort option Excel provides for what I want to achieve.

I need some help in restructuring data that I download frequently from a website for products and upload them after updating prices and some other information. The issue I run into is that some of the parent and child records are scattered and I often have to manually move the rows to make updates resulting in hours of lost time. Since we download and upload it frequently I think it makes sense to write a macro for restructuring the rows.

Here's an example of the data that we download:

ID	Short Desc	Parent	Reg Price	Sale Price	lots of other cols.
660	Product 1				...
661	Product 2				...
662		661	45	40	...
663		660	50	44	...
664		660	44	23	...
665	Product 3				...
666		661	55	55
667		661	12	11	...
668		665	10	9	...
...		...	...	...	...

<tbody>
</tbody>

ID is just a running number when each new product is created in the system. Parent col is empty when it's a parent record, if it has ID in it then it's a child product and it's linked to the Parent product. In this case, I'd like the code to move rows 4 and 5 from above table below row 1, example below:

ID	Short Desc	Parent	Reg Price	Sale Price
660	Product 1
663		660
664		660
661	Product 2
662		661
666		661
667		661
665	Product 3

<tbody>
</tbody>

I'm using Office 2016 version.

Thanks in advance!

 

[MickG]

Try this for results on sheet2.

To Save and Run Code:-
Copy code from Thread
In Your Data sheet , Click "Alt+F11",:- Vb Window appears.
From the VBWindow toolbar, Click "Insert" ,"Module":- New VBwindow appears .
Paste Code into this window.
Close Vbwindow.
On sheet Click "Developer tab", Click "Macro". Macro dialog box appears.
Select Macro (with same name) from List.
On the right of Dialog box Click "Run"
Sheet2 should now be updated.

[COLOR=navy]Sub[/COLOR] MG30Nov39
[COLOR=navy]Dim[/COLOR] Ray [COLOR=navy]As[/COLOR] Variant, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] col [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] k [COLOR=navy]As[/COLOR] Variant, p [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
Ray = ActiveSheet.Cells(1).CurrentRegion
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
ReDim nray(1 To UBound(Ray, 1), 1 To UBound(Ray, 2))
[COLOR=navy]For[/COLOR] Ac = 1 To UBound(Ray, 2)
    nray(1, Ac) = Ray(1, Ac)
[COLOR=navy]Next[/COLOR] Ac
c = 1
    [COLOR=navy]For[/COLOR] n = 2 To UBound(Ray, 1)
        [COLOR=navy]If[/COLOR] Not IsEmpty(Ray(n, 3)) [COLOR=navy]Then[/COLOR]
        [COLOR=navy]If[/COLOR] Not .Exists(Ray(n, 3)) [COLOR=navy]Then[/COLOR]
            ReDim R(1 To UBound(Ray, 1))
            R(1) = n
            .Add Ray(n, 3), Array(R, 1)
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Ray(n, 3))
            Q(1) = Q(1) + 1
            Q(0)(Q(1)) = n
            .Item(Ray(n, 3)) = Q
        [COLOR=navy]End[/COLOR] If
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] n
[COLOR=navy]Dim[/COLOR] t
[COLOR=navy]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] k [COLOR=navy]In[/COLOR] .keys
        [COLOR=navy]If[/COLOR] k = Ray(n, 1) And Not IsEmpty(Ray(n, 2)) [COLOR=navy]Then[/COLOR]
            c = c + 1
            nray(c, 1) = Ray(n, 1): nray(c, 2) = Ray(n, 2)
            [COLOR=navy]For[/COLOR] p = 1 To UBound(Ray, 1)
                [COLOR=navy]If[/COLOR] .Item(k)(0)(p) <> "" [COLOR=navy]Then[/COLOR]
                    c = c + 1
                    [COLOR=navy]For[/COLOR] Ac = 1 To UBound(Ray, 2)
                        [COLOR=navy]If[/COLOR] Not IsEmpty(Ray(.Item(k)(0)(p), Ac)) [COLOR=navy]Then[/COLOR]
                            nray(c, Ac) = Ray(.Item(k)(0)(p), Ac)
                        [COLOR=navy]End[/COLOR] If
                    [COLOR=navy]Next[/COLOR] Ac
                [COLOR=navy]End[/COLOR] If
           [COLOR=navy]Next[/COLOR] p
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] k
[COLOR=navy]Next[/COLOR] n
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(UBound(Ray, 1), UBound(Ray, 2))
    .Value = nray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR=navy]End[/COLOR] With

[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[scorleo]

Try this for results on sheet2.

Regards Mick

Thanks Mick. Unfortunately, I'm getting this error message

http://prntscr.com/hh9unj

First I thought it was because of sheet name so I changed it from Sheet2 to Sheet1 and I still get the error, I don't have Sheet1 in my workbook currently.

Thanks again!

 

[scorleo]

Try this for results on sheet2.


Regards Mick

Please ignore previous response, I created Sheet1 and ran the code and it creates rows and headers but no data --> http://prntscr.com/hh9y64

 

[scorleo]

So I moved the ParentID column to 3rd position from 20th and I see a different error now --> http://prntscr.com/hha2a2

I change the col 1 and 3 to number to make sure they both are same types, by default both are General.

 

[MickG]

Have a look at this example:-
If you actual data is different, and does not work with this code, please show an new example of your data.
https://app.box.com/s/5py3ntnco4yxad4ppdd08f7ji13ehdvh

 

[scorleo]

Thank you Mick!

The code works but here's what I had to do, cell number 3 (Parent2) uses a formula to remove "ID:" from another col called Parent, because of use of formula it was giving errors. When I hard coded the numbers to run a test it moved the rows perfectly the way I want.

However, my key issue still remains because the Parent column includes "ID:", the current code results in mismatch error as before. Here's my actual column sample --> http://prntscr.com/hhadbi

 

[scorleo]

Have a look at this example:-
If you actual data is different, and does not work with this code, please show an new example of your data.
https://app.box.com/s/5py3ntnco4yxad4ppdd08f7ji13ehdvh

Here's the actual sample, please see previous reply as well for more information --> http://prntscr.com/hhadbi

Many Thanks!

 

[MickG]

Is it possible to send the file (or accurate example of) with limited expected results, using www.box.com (free file sharing) or similar, so I can see the actual problems.
NB:- Images need to be manually copied to the sheet and not all details are apparent !!!

 

[scorleo]

Is it possible to send the file (or accurate example of) with limited expected results, using www.box.com (free file sharing) or similar, so I can see the actual problems.
NB:- Images need to be manually copied to the sheet and not all details are apparent !!!

Just sent in a private message. Thanks a lot!