Macro to rearrange structure of report.

Carl_H

New Member
Joined
Sep 16, 2014
Messages
18
Hello,

Is it possible to change the structure of this report:

2nia59i.jpg



To look like this:
2924avk.jpg
[/IMG]

if anyone can help me I would be very grateful.

My report has a lot more rows than above but the columns are the same.
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Hello,

I was thinking maybe it will be easier if a make a table that you can copy paste into an excelsheet. If you need further information I'll do my best to provide it for you.

Also there is 2 blanks between * and the cost center name, and 3 blanks before the cost element if that is important facts.
Act. per 8</SPAN>
Plan. per 8</SPAN>
Var. per 8</SPAN>
Cost centers/Cost elements</SPAN>
Act per 01 - 8</SPAN>
Plan version 3</SPAN>
1769</SPAN>
41666,66</SPAN>
-39897,66</SPAN>
591202 Customer magazines, production</SPAN>
453677</SPAN>
500000</SPAN>
-140</SPAN>
0</SPAN>
-140</SPAN>
591816 Customer magazines</SPAN>
-2520</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
625001 Postal expenses</SPAN>
-1499990,5</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
655901 Other consultant fees</SPAN>
217271</SPAN>
0</SPAN>
148</SPAN>
0</SPAN>
148</SPAN>
659202 Hired Services Elanders (Publ Store)</SPAN>
752</SPAN>
0</SPAN>
1777</SPAN>
41666,66</SPAN>
-39889,66</SPAN>
* 19065 Customer magazines</SPAN>
-830810,5</SPAN>
500000</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
564901 Demo/test vehicle miscellaneous</SPAN>
107138</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
* 19066 VT Press Test</SPAN>
107138</SPAN>
0</SPAN>
0</SPAN>
4166,66</SPAN>
-4166,66</SPAN>
591101 Daily press media space</SPAN>
0</SPAN>
50000</SPAN>
0</SPAN>
41666,66</SPAN>
-41666,66</SPAN>
591201 Magazine media space</SPAN>
329504,25</SPAN>
500000</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
591802 Advertising</SPAN>
10000</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
595002 POS production</SPAN>
13158</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
597102 Photos production</SPAN>
1500</SPAN>
0</SPAN>
0</SPAN>
4583,34</SPAN>
-4583,34</SPAN>
597401 Internet</SPAN>
0</SPAN>
55000</SPAN>
0</SPAN>
8333,34</SPAN>
-8333,34</SPAN>
599701 Other advertising costs</SPAN>
136700</SPAN>
100000</SPAN>
0</SPAN>
8333,34</SPAN>
-8333,34</SPAN>
615001 Printed matter</SPAN>
11406</SPAN>
100000</SPAN>
0</SPAN>
67083,34</SPAN>
-67083,34</SPAN>
* 19067 VT Advertising</SPAN>
502268,25</SPAN>
805000</SPAN>
0</SPAN>
2083,34</SPAN>
-2083,34</SPAN>
564901 Demo/test vehicle miscellaneous</SPAN>
25120</SPAN>
25000</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
581003 Tickets other countries</SPAN>
0</SPAN>
0</SPAN>
14290</SPAN>
1250</SPAN>
13040</SPAN>
597102 Photos production</SPAN>
14290</SPAN>
15000</SPAN>
0</SPAN>
28750</SPAN>
-28750</SPAN>
598401 Sponsorship</SPAN>
326058,2</SPAN>
345000</SPAN>
0</SPAN>
0</SPAN>
0</SPAN>
609801 Other sales costs</SPAN>
173,41</SPAN>
0</SPAN>
25119,13</SPAN>
0</SPAN>
25119,13</SPAN>
783501 Depreciation of cars</SPAN>
25119,13</SPAN>
0</SPAN>
39409,13</SPAN>
32083,34</SPAN>
7325,79</SPAN>
* 19069 VT PR/Media</SPAN>
390760,74</SPAN>
385000</SPAN>

<TBODY>
</TBODY>
 
Last edited:
Upvote 0
With the additional headings removed try:

Code:
Sub Test()
    Dim ShNew As Worksheet
    Dim LastRow As Long
    Dim First As Long
    Dim r As Long
    Dim i As Long
    Set ShNew = Worksheets.Add
    ShNew.Range("A1:I1").Value = Array("Act. per 8", "Plan. per 8", "Var. per 8", "Cost center", "Cost center text", "Cost element", "Cost element text", "Act per 01 - 8", "Plan version 3")
    First = 2
    r = 2
    With Worksheets("Sheet1")
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        For i = 2 To LastRow
            If Left(.Range("D" & i).Value, 1) <> "*" Then
                .Range("A" & i).Resize(, 3).Copy ShNew.Range("A" & r)
                ShNew.Range("F" & r).Value = Left(.Range("D" & i).Value, 6)
                ShNew.Range("G" & r).Value = Mid(.Range("D" & i).Value, 8)
                .Range("E" & i).Resize(, 2).Copy ShNew.Range("H" & r)
                r = r + 1
            Else
                ShNew.Range("D" & First & ":D" & r - 1).Value = Mid(Trim(.Range("D" & i).Value), 3, 5)
                ShNew.Range("E" & First & ":E" & r - 1).Value = Mid(Trim(.Range("D" & i).Value), 9)
                First = r
            End If
        Next i
    End With
End Sub
 
Upvote 0
Hello,

First of all, thanks for your effort so far. It almost worked.

The result when I ran the macro can be found below: As you can see, last digit of cost center is missing, and if you paste the data below into an excel sheet you will also see that the cost element number only displays 3 digits in the correct column.

If you reply, I will not have time to check new result until tomorrow as I am about to leave work.

And by the way: I just started my new job and when I can start to use this macro I will be able to rebuild our report which will easily save me 30-40 hours a month, not having to do any copy paste which my former colleague seemed to like :) So once again. Thanks a lot!

EDIT: I did not include cost center 19066 below.
Act. per 8</SPAN>
Plan. per 8</SPAN>
Var. per 8</SPAN>
Cost center</SPAN>
Cost center text</SPAN>
Cost element</SPAN>
Cost element text</SPAN>
Act per 01 - 8</SPAN>
Plan version 3</SPAN>
4 166,66</SPAN>
4 166,66-</SPAN>
1906</SPAN>
VT Advertising</SPAN>
591</SPAN>
01 Daily press media space</SPAN>
50 000,00</SPAN>
41 666,66</SPAN>
41 666,66-</SPAN>
1906</SPAN>
VT Advertising</SPAN>
591</SPAN>
01 Magazine media space</SPAN>
329 504,25</SPAN>
500 000,00</SPAN>
1906</SPAN>
VT Advertising</SPAN>
591</SPAN>
02 Advertising</SPAN>
10 000,00</SPAN>
1906</SPAN>
VT Advertising</SPAN>
595</SPAN>
02 POS production</SPAN>
13 158,00</SPAN>
1906</SPAN>
VT Advertising</SPAN>
597</SPAN>
02 Photos production</SPAN>
1 500,00</SPAN>
4 583,34</SPAN>
4 583,34-</SPAN>
1906</SPAN>
VT Advertising</SPAN>
597</SPAN>
01 Internet</SPAN>
55 000,00</SPAN>
8 333,34</SPAN>
8 333,34-</SPAN>
1906</SPAN>
VT Advertising</SPAN>
599</SPAN>
01 Other advertising costs</SPAN>
136 700,00</SPAN>
100 000,00</SPAN>
8 333,34</SPAN>
8 333,34-</SPAN>
1906</SPAN>
VT Advertising</SPAN>
615</SPAN>
01 Printed matter</SPAN>
11 406,00</SPAN>
100 000,00</SPAN>
2 083,34</SPAN>
2 083,34-</SPAN>
1906</SPAN>
VT PR/Media</SPAN>
564</SPAN>
01 Demo/test vehicle miscellaneous</SPAN>
25 120,00</SPAN>
25 000,00</SPAN>
1906</SPAN>
VT PR/Media</SPAN>
581</SPAN>
03 Tickets other countries</SPAN>
14 290,00</SPAN>
1 250,00</SPAN>
13 040,00</SPAN>
1906</SPAN>
VT PR/Media</SPAN>
597</SPAN>
02 Photos production</SPAN>
14 290,00</SPAN>
15 000,00</SPAN>
28 750,00</SPAN>
28 750,00-</SPAN>
1906</SPAN>
VT PR/Media</SPAN>
598</SPAN>
01 Sponsorship</SPAN>
326 058,20</SPAN>
345 000,00</SPAN>
1906</SPAN>
VT PR/Media</SPAN>
609</SPAN>
01 Other sales costs</SPAN>
173,41</SPAN>
25 119,13</SPAN>
25 119,13</SPAN>
1906</SPAN>
VT PR/Media</SPAN>
783</SPAN>
01 Depreciation of cars</SPAN>
25 119,13</SPAN>

<TBODY>
</TBODY>
 
Last edited:
Upvote 0
This is what I got with your sample data:


Excel 2010
ABCDEFGHI
1Act. per 8Plan. per 8Var. per 8Cost centerCost center textCost elementCost element textAct per 01 - 8Plan version 3
2176941666.66-39897.6619065Customer magazines591202Customer magazines. production453677500000
3-1400-14019065Customer magazines591816Customer magazines-25200
400019065Customer magazines625001Postal expenses-1499990.50
500019065Customer magazines655901Other consultant fees2172710
6148014819065Customer magazines659202Hired Services Elanders (Publ Store)7520
700019066VT Press Test564901Demo/test vehicle miscellaneous1071380
804166.66-4166.6619067VT Advertising591101Daily press media space050000
9041666.66-41666.6619067VT Advertising591201Magazine media space329504.25500000
1000019067VT Advertising591802Advertising100000
1100019067VT Advertising595002POS production131580
1200019067VT Advertising597102Photos production15000
1304583.34-4583.3419067VT Advertising597401Internet055000
1408333.34-8333.3419067VT Advertising599701Other advertising costs136700100000
1508333.34-8333.3419067VT Advertising615001Printed matter11406100000
1602083.34-2083.3419069VT PR/Media564901Demo/test vehicle miscellaneous2512025000
1700019069VT PR/Media581003Tickets other countries00
181429012501304019069VT PR/Media597102Photos production1429015000
19028750-2875019069VT PR/Media598401Sponsorship326058.2345000
2000019069VT PR/Media609801Other sales costs173.410
2125119.13025119.1319069VT PR/Media783501Depreciation of cars25119.130
Sheet4
 
Upvote 0
Hello,

with the data I pasted at first it works beautifully. However, it seems extra "blanks" have been removed when I pasted the data. My data set looks like * "blank" "blank" 19065 Customer magazines (* 19065 Customer magazines) and for the cost elements there is e.g. "blank" "blank" "blank" 591202 Customer magazines, production ( 591202 Customer magazines, production).
 
Upvote 0
How about?

Code:
Sub Test()
    Dim ShNew As Worksheet
    Dim LastRow As Long
    Dim First As Long
    Dim r As Long
    Dim i As Long
    Set ShNew = Worksheets.Add
    ShNew.Range("A1:I1").Value = Array("Act. per 8", "Plan. per 8", "Var. per 8", "Cost center", "Cost center text", "Cost element", "Cost element text", "Act per 01 - 8", "Plan version 3")
    First = 2
    r = 2
    With Worksheets("Sheet1")
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        For i = 2 To LastRow
            If Left(.Range("D" & i).Value, 1) <> "*" Then
                .Range("A" & i).Resize(, 3).Copy ShNew.Range("A" & r)
                ShNew.Range("F" & r).Value = Left(WorksheetFunction.Trim(.Range("D" & i).Value), 6)
                ShNew.Range("G" & r).Value = Mid(WorksheetFunction.Trim(.Range("D" & i).Value), 8)
                .Range("E" & i).Resize(, 2).Copy ShNew.Range("H" & r)
                r = r + 1
            Else
                ShNew.Range("D" & First & ":D" & r - 1).Value = Mid(WorksheetFunction.Trim(.Range("D" & i).Value), 3, 5)
                ShNew.Range("E" & First & ":E" & r - 1).Value = Mid(WorksheetFunction.Trim(.Range("D" & i).Value), 9)
                First = r
            End If
        Next i
    End With
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,048
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top