Condensing and Rearranging Data

touche · Aug 20, 2011

OK, So I am having a terrible time writing the code to display the information like I need it displayed. I was hoping someone here could assist me with this.

So when I get this spreadsheet the data is not in a nice neat concise package. So I was hoping to configure it to be so. What I was looking to do was grab the key information I need in column A and transition it to be column headers. I have identified only the column headers I want but there is a twist in this for me as certain lines where the part descriptions and info is housed already exist in a column row format.
Such as:

 General Info
Number 12345
Address
City
State
Order Date 8/19/2011
Notes This is a test
Line# Description Cost Qty Tax Delivery Currency
1 Part1 $5.00 3 USD
2 part2 $3.00 2 USD
3 part3 $5.00 3 USD
Order Summary
[FONT=&quot]Total Items 3[/FONT]

I would like this to displayed like this:

 Number Order Date Notes Line# Description Cost Qty
12345 8/19/2011 This is a test 1 Part1 $5.00 3
12345 8/19/2011 This is a test 2 part2 $3.00 2
[FONT=&quot]12345 8/19/2011 This is a test 3 part3 $5.00 3[/FONT]

This information repeats. So where "Total Items" ends there will be another "General Info" below it and each order number can have various different parts on it. The information is consistent though and the only variable that changes is how many parts exist for a certain order number. I hope this makes sense. I will attach a screen shot that hopefully explains it a little better.

Uploaded with ImageShack.us

jbeaucaire · Aug 20, 2011

1) Put the data on a sheet called "Data"
2) Insert a blank sheet named "OutPut"
3) Run this macro:

Code:

Option Explicit

Sub ReformatData()
Dim vFIND As Range, vFIRST As Range, OrdSum As Range
Dim wsOUT As Worksheet, NR As Long, Rws As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set wsOUT = Sheets("OutPut")    'sheet to create new layout
wsOUT.Cells.ClearContents
wsOUT.Range("A1:G1").Value = [{"Number","Order Date","Notes","Line#","Description","Cost","Qty"}]
NR = 2

With Sheets("Data")             'list the name of the data sheet here
    Set vFIND = .Range("A:A").Find("Number", LookIn:=xlValues, LookAt:=xlPart)
    If vFIND Is Nothing Then
        MsgBox "Unable to find the first set of data, please check the data and try again"
        wsOUT.Delete
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    Set vFIRST = vFIND
    Do
        Set OrdSum = .Range("A:A").Find("Summary", After:=vFIND, LookIn:=xlValues, LookAt:=xlPart)
        .Range(vFIND.Offset(8), OrdSum.Offset(-1, 3)).Copy wsOUT.Range("D" & NR)
        Rws = OrdSum.Row - vFIND.Row - 8
        wsOUT.Range("A" & NR).Resize(Rws).Value = vFIND.Offset(0, 1).Value
        wsOUT.Range("B" & NR).Resize(Rws).Value = vFIND.Offset(5, 1).Value
        wsOUT.Range("C" & NR).Resize(Rws).Value = vFIND.Offset(6, 1).Value
        
        NR = NR + Rws
        Set vFIND = .Range("A:A").Find("Number", After:=OrdSum, LookIn:=xlValues, LookAt:=xlPart)
    Loop Until vFIND.Address = vFIRST.Address
End With

wsOUT.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

MickG · Aug 20, 2011

Try this :-
Results Sheet(2)

Code:

[COLOR="Navy"]Sub[/COLOR] MG20Aug51
[COLOR="Navy"]Dim[/COLOR] Header       [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rng          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn           [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Temp(1 To 3) [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] H            [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Fd           [COLOR="Navy"]As[/COLOR] Boolean
[COLOR="Navy"]Dim[/COLOR] c            [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim Ray(1 To Rng.Count, 1 To 7)
Header = Array("Number", "Order Date", "Notes", "Line#", "Description", "Cost", "Qty")
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]For[/COLOR] H = 0 To 2
        [COLOR="Navy"]If[/COLOR] Dn = Header(H) [COLOR="Navy"]Then[/COLOR] Temp(H + 1) = Dn.Offset(, 1)
    [COLOR="Navy"]Next[/COLOR] H
    [COLOR="Navy"]If[/COLOR] Dn = "Order" [COLOR="Navy"]Then[/COLOR] Fd = False
        [COLOR="Navy"]If[/COLOR] Fd = True [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            Ray(c, 1) = Temp(1): Ray(c, 2) = Temp(2): Ray(c, 3) = Temp(3)
            Ray(c, 4) = Dn: Ray(c, 5) = Dn.Offset(, 1): Ray(c, 6) = Dn.Offset(, 2)
            Ray(c, 7) = Dn.Offset(, 3)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]If[/COLOR] Dn = "Line#" [COLOR="Navy"]Then[/COLOR] Fd = True
 [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]With[/COLOR] Sheets("sheet2")
        .Range("a1").Resize(, 7) = Header
        .Range("A2").Resize(c, 7) = Ray
    [COLOR="Navy"]End[/COLOR] With
MsgBox "Run!!"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

touche · Aug 20, 2011

jbeaucaire,

Thanks! The base code you supplied was a big a help! After a little fiddling I got the results I needed. Mainly just alignment things.

This is what I ended up with.

Option Explicit

Sub ReformatData()
Dim vFIND As Range, vFIRST As Range, OrdSum As Range
Dim wsOUT As Worksheet, NR As Long, Rws As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set wsOUT = Sheets("OutPut") 'sheet to create new layout
wsOUT.Cells.ClearContents
wsOUT.Range("A1:G1").Value = [{"Number","Order Date","Notes","Line#","Description","Cost","Qty"}]
NR = 2

With Sheets("Data") 'list the name of the data sheet here
Set vFIND = .Range("A:A").Find("Number", LookIn:=xlValues, LookAt:=xlPart)
If vFIND Is Nothing Then
MsgBox "Unable to find the first set of data, please check the data and try again"
wsOUT.Delete
Application.ScreenUpdating = True
Exit Sub
End If

Set vFIRST = vFIND
Do
Set OrdSum = .Range("A:A").Find("Summary", After:=vFIND, LookIn:=xlValues, LookAt:=xlPart)
.Range(vFIND.Offset(7), OrdSum.Offset(-1, 3)).Copy wsOUT.Range("D" & NR)
Rws = OrdSum.Row - vFIND.Row - 7
wsOUT.Range("A" & NR).Resize(Rws).Value = vFIND.Offset(0, 1).Value
wsOUT.Range("B" & NR).Resize(Rws).Value = vFIND.Offset(4, 1).Value
wsOUT.Range("C" & NR).Resize(Rws).Value = vFIND.Offset(5, 1).Value

NR = NR + Rws
Set vFIND = .Range("A:A").Find("Number", After:=OrdSum, LookIn:=xlValues, LookAt:=xlPart)
Loop Until vFIND.Address = vFIRST.Address
End With
wsOUT.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

Thanks Again!

Mick,

Just noticed your post. I'll give it a shot as well and report back. Thanks!

Condensing and Rearranging Data

touche

New Member

Excel Facts

jbeaucaire

Well-known Member

MickG

MrExcel MVP

touche

New Member

Similar threads

Forum statistics

Share this page

Condensing and Rearranging Data

touche

New Member

Excel Facts

jbeaucaire

Well-known Member

MickG

MrExcel MVP

touche

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock