[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Need an Excel Macro to copy data to a new tab in 20 line segments

Posted on 2007-08-10
10
Medium Priority
?
823 Views
Last Modified: 2013-11-25
Hello,
Thank you in advance for helping me out.  My needs are to simply take a Pivot table, and copy the data into a new tab, but in 20 line segments. In the example below, please look at the row numbers in the before and after to see exactly what I'm looking for.  I'm looking to turn this:


Car Maker        Color        Stock#       Description
01  Ford Cars         Blue        563286       4 Door
02                          Green      686595       2 Door
03                          Orange   542111       SUV
04  Toyota Cars      Green    656565       2 Door
05                          Orange  545454       asdfasdf
06                           Red      323255       descriptive text
07  Honda Cars       Red    111225         4 Door




In to this:






Car Maker        Color        Stock#       Description
01  Ford Cars         Blue        563286       4 Door
02                          Green      686595       2 Door
03                          Orange   542111       SUV

21  Toyota Cars      Green    656565       2 Door
22                          Orange  545454       asdfasdf
23                           Red      323255       descriptive text

41  Honda Cars       Red    111225         4 Door



Please let me know if you need additional details and thank you so much for helping.
Regards,
Tod
0
Comment
Question by:tkeiffer
  • 5
  • 4
10 Comments
 
LVL 21

Expert Comment

by:oleggold
ID: 19673634
0
 
LVL 38

Expert Comment

by:jeverist
ID: 19674520
Hi Tod,

If your PivotTable does not have any Total rows (like your example) then try this routine:

Sub CopyPivotData()
Dim ws As Worksheet, ws_new As Worksheet, pt As PivotTable, rng As Range, cel As Range, rngcpy As Range, irow As Long

Set ws = ActiveSheet
Set ws_new = Worksheets.Add

If ws.PivotTables.Count < 1 Then
    MsgBox "No PivotTables found on ActiveSheet.  Exiting routine.", vbInformation
    Exit Sub
End If

Set pt = ws.PivotTables(1)
Set rng = pt.TableRange1

Set cel = rng.Columns(1).Cells(2)
irow = 1

Do While cel.Row < rng.Rows.Count + rng.Row - 1
    Set rngcpy = Range(cel, cel.End(xlDown).Offset(-1)).Resize(ColumnSize:=rng.Columns.Count)
    rngcpy.Copy Destination:=ws_new.Cells(irow, "A")
   
    Set cel = cel.End(xlDown)
    irow = irow + 20
Loop

End Sub

Let me nkow how this works for you.

Jim
0
 

Author Comment

by:tkeiffer
ID: 19686160
Hi Jim,
Thank you very much for helping me out.  Would there be a way for this code to work on data that is not in a pivot table?  I will be moving select content from a pivot into a new sheet rather then run the procedure on the entire pivot table.  Therefore I would prefer it to run just analyzing columns A through D.

The dataset could be of any size to answer your Total rows question.
Thanks again for all your help.
Tod
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 

Author Comment

by:tkeiffer
ID: 19686327
I kind of screwed this question up.  What my situation is like is this.  The pivot actually looks more like the one below.  The data I'm interested in moving is only the Car Maker.  The Car Maker is organized by ID.  I can't take ID out of the pivot table because then it will combine all the Car makers together.  In the example below, If you took ID out of the Pivot, the Ford cards would be combined into 1 section.  I need it to be separate.

So, I was just going to copy the text from Car Maker, Color, Stock# and Description into a new sheet, and run a macro that does as I described above.  Does that make sense?  I'm sorry for the confusion. - T

       ID       Car Maker        Color        Stock#       Description
01   A2         Ford Cars         Blue        563286       4 Door
02                                       Green      686595       2 Door
03                                      Orange   542111       SUV
04                 Toyota Cars      Green    656565       2 Door
05                                     Orange  545454       asdfasdf
06                                      Red      323255       descriptive text
07   A3         Honda Cars       Red    111225         4 Door
......
15   A6          Ford Cars      Grey     848484         Hatchback
0
 

Author Comment

by:tkeiffer
ID: 19687039
Hello again Jim,
In the meantime I found a way to use this code by concatenating the first field with the second and creating another pivot table, however I found that the code was making one small mistake.  If you runt he macro on the pivot when it looks like this:

Car Maker      Color      Stock#      Description
Ford Cars      Blue      463286      4 Door
                    Green      656565      2 Door
                    Orange      98654      SUV
Honda Cars   Red      897546      e;lkjr;lkjekljrhkljhe
Chevy Cars    Black      98798798      dkfnjhklabnkl
Toyota Cars      Green      523656      2 Door
                   Orange      123456      asdf
                   Red      564654      asdfasdflk;j

Then the macro combines the two unique lines together instead of separating them by 20 lines:

Honda Cars   Red      897546      e;lkjr;lkjekljrhkljhe
Chevy Cars    Black      98798798      dkfnjhklabnkl

and then it adds 20 lines after Chevy Cars.  It should add 20 lines after every unique "car maker".

I'm sorry about the confusion.
0
 
LVL 38

Expert Comment

by:jeverist
ID: 19688941
Tod,

>  The pivot actually looks more like the one below

I still think it may be better to start with the sheet that has the pivot table and just grab the data we're interested in.  Try this from sheet with the pivot:

Sub CopyPivotDataII()
Dim ws As Worksheet, ws_new As Worksheet, pt As PivotTable, rng As Range, cel As Range, rngcpy As Range, i As Long, irow As Long

Set ws = ActiveSheet
Set ws_new = Worksheets.Add

If ws.PivotTables.Count < 1 Then
    MsgBox "No PivotTables found on ActiveSheet.  Exiting routine.", vbInformation
    Exit Sub
End If

Set pt = ws.PivotTables(1)
Set rng = pt.TableRange1.Columns(2)

irow = 1
i = rng.Row

For Each cel In rng.Cells
    If (cel.Value <> cel.Offset(1).Value And cel.Offset(1).Value <> "" And cel.Row <> 1) Or cel.Row = rng.Cells(rng.Cells.Count).Row Then
        Set rngcpy = Range(rng.Cells(i), cel)
        rngcpy.Resize(ColumnSize:=pt.TableRange1.Columns.Count - 1).Copy Destination:=ws_new.Cells(irow, "A")
        i = cel.Offset(1).Row
        irow = irow + 20
    End If
Next cel

End Sub

Let me know if this works for you.

Jim
0
 

Author Comment

by:tkeiffer
ID: 19710141
Hi Jim,
Thank you so much for your help and sorry for the delay.  I've attached a spreadsheet that has a simple pivot with the data I'm actually using, and an example sheet of how I'm trying to sort the data.  Is this possible?

http://my.storenow.net?f=1767 
0
 
LVL 38

Accepted Solution

by:
jeverist earned 2000 total points
ID: 19711926
Tod,

OK, that's a little different but still doable.  Try this:

Sub CopyPivotData()
Dim ws As Worksheet, ws_new As Worksheet, pt As PivotTable, rng As Range, cel As Range, rngcpy As Range, irow As Long, i As Long

Application.DisplayAlerts = False

Set ws = ActiveSheet
Set ws_new = Worksheets.Add

If ws.PivotTables.Count < 1 Then
    MsgBox "No PivotTables found on ActiveSheet.  Exiting routine.", vbInformation
    Exit Sub
End If

Set pt = ws.PivotTables(1)
irow = pt.RowRange.Row - pt.TableRange1.Row + 1
Set rng = pt.TableRange1.Offset(irow).Resize(pt.TableRange1.Rows.Count - irow)
ws.Rows(rng.Row - 1).Copy
ws_new.Cells(1, 1).PasteSpecial Paste:=xlPasteValues

Set cel = rng.Cells(1)
irow = 2

i = rng.Row

For Each cel In rng.Columns(2).Cells
    If (cel.Value <> cel.Offset(1).Value And cel.Offset(1).Value <> "" And cel.Row <> rng.Row) Or cel.Row = rng.Cells(rng.Cells.Count).Row Then
        Set rngcpy = Range(rng.Columns(2).Cells(i - rng.Row + 1), cel).Offset(0, -1).Resize(ColumnSize:=rng.Columns.Count)
        rngcpy.Copy Destination:=ws_new.Cells(irow, "A")
        If ws_new.Cells(irow, "A") = "" Then
            ws_new.Cells(irow, "A") = ws_new.Cells(irow, "A").End(xlUp)
        End If
       
        ws_new.Cells(irow, "A").Resize(ws_new.Cells(ws_new.Rows.Count, "A").Offset(0, 2).End(xlUp).Row - irow + 1, 2) = ws_new.Cells(irow, "A").Resize(1, 2).Value
       
        i = cel.Offset(1).Row
        irow = irow + 20
    End If
Next cel

ws_new.UsedRange.SpecialCells(xlCellTypeLastCell).EntireRow.Delete ' Remove Grand Total row
ws_new.UsedRange.AutoFormat Format:=xlRangeAutoFormatSimple

Application.DisplayAlerts = True
Application.Goto ws_new.[A1]

End Sub

Jim
0
 

Author Comment

by:tkeiffer
ID: 19711980
That's the winner. Thank you Jim.  I apologize for opening a duplicate, I looked at your history and it seemed like you might be out for a few.  Thank you so much for your help.
0
 
LVL 38

Expert Comment

by:jeverist
ID: 19712441
tkeiffer,

>  you might be out for a few

If you mean you think I've been busy for the past few days then you are correct.

Good luck and thanks for the grade!

Jim
0

Featured Post

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.

834 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question