Rearranging large amounts of data

If the data forms a nice rectangle, it's fairly easy to do this with some formulas and a copy/paste special values. However, since I don't know if that's the case, it's easiest to do this with a macro. I made a couple of assumptions, though.
Assumption 1:
the company names will be held in cells A1, E1, I1, etc., either by merged cells, or center across selection, or some other method.
Assumption 2: you don't mind copy/pasting the headers h1,h2,h3,h4 into the final positions (this is a one time thing, right?)

This macro will take the data from the currently active sheet, and place it into a newly added sheet in the same workbook.

Sub FixFourColumnData()
    Dim lCtrIn           As Long
    Dim lCtrOut          As Long
    Dim lColNbr          As Long

    Dim wsInput          As Worksheet
    Dim wsOutput         As Worksheet

    Set wsInput = ActiveSheet
    Set wsOutput = Worksheets.Add

    lCtrIn = 3
    lCtrOut = 2
    lColNbr = 1

    Do
        'check to see if we're at the end of a col.
        'if so, move over to next group of 4, and reset
        'to the first row of data
        If wsInput.Cells(lCtrIn, lColNbr) = "" Then
            lColNbr = lColNbr + 4
            lCtrIn = 3
            If wsInput.Cells(lCtrIn, lColNbr) = "" Then Exit Do
            'check to see if the first item in the 4 column group
            'is blank.  if it's blank, we've ran through the
            'whole data set for the given company.
        End If

        'copy the info to the output sheet
        wsOutput.Cells(lCtrOut, 1) = wsInput.Cells(1, lColNbr)
        wsOutput.Range(wsOutput.Cells(lCtrOut, 2), wsOutput.Cells(lCtrOut, 5)).Value _
                = wsInput.Range(wsInput.Cells(lCtrIn, lColNbr), wsInput.Cells(lCtrIn, lColNbr + 4)).Value
        'set the counter to look at the next row on the input sheet.
        lCtrIn = lCtrIn + 1
        'set the counter to output to the next row on the output sheet
        lCtrOut = lCtrOut + 1
    Loop

End Sub

cjo,

Firstly thank you very much for the reply & effort you put into that post.

I should have mentioned that the information is not in a nice rectangle. The first column is a date and this is not uniform across the companies.

I had hoped there was an easy way to do this on Excel, my experience with macros is very limited. I should have said in the original post that there is actually 13 columns per company (12 + company name/H0). Is it easy to modify the macro to include this?

Re the assumptions:

1- The company names will be held in the first row. A will be a2-a?, B will be a?-a?? etc.

2- Actually a fourteen time thing as it didn't all fit into one spreadsheet. But you're correct I certainly don't mind doing that.


Thanks again for the help!

Changing the number of columns on the final spreadsheet isn't hard.

First, though, what I meant by "Nice Rectangle" is each company has the same number of rows. That is fairly simple thing to do with formulas. If each company has a different number of rows underneath them, then I can't think of a formula off hand that wouldn't require a clean up using an autofilter.

As to the assumptions, I think we've got some tenses confused. In your current sheet, can the company names can be seen in cells A1, M1, Y1, etc?
Also, I'm just leaving the top row blank for the headers. So long as your headers h1, h2, etc don't change value, you should only have to copy/paste it over once.

As to some new information you just provided, is your data is currently spread across multiple worksheets? If so, it could be possible to save you some effort. Do the worksheets have some sort of similarity in the names, or some other way to give a good positive identification that they should be included in this cleanup/merge?

Anyway, here's the revised (for now) code.

Sub FixFourColumnData()
    Dim lCtrIn           As Long
    Dim lCtrOut          As Long
    Dim lColNbr          As Long

    Dim wsInput          As Worksheet
    Dim wsOutput         As Worksheet

    Set wsInput = ActiveSheet
    Set wsOutput = Worksheets.Add

    lCtrIn = 3
    lCtrOut = 2
    lColNbr = 1

    Do
        'check to see if we're at the end of a col.
        'if so, move over to next group of 12, and reset
        'to the first row of data
        If wsInput.Cells(lCtrIn, lColNbr) = "" Then
            lColNbr = lColNbr + 12
            lCtrIn = 3
            If wsInput.Cells(lCtrIn, lColNbr) = "" Then Exit Do
            'check to see if the first item in the 4 column group
            'is blank.  if it's blank, we've ran through the
            'whole data set for the given company.
        End If

        'copy the info to the output sheet
        wsOutput.Cells(lCtrOut, 1) = wsInput.Cells(1, lColNbr)
        wsOutput.Range(wsOutput.Cells(lCtrOut, 2), wsOutput.Cells(lCtrOut, 13)).Value _
                = wsInput.Range(wsInput.Cells(lCtrIn, lColNbr), wsInput.Cells(lCtrIn, lColNbr + 11)).Value
        'set the counter to look at the next row on the input sheet.
        lCtrIn = lCtrIn + 1
        'set the counter to output to the next row on the output sheet
        lCtrOut = lCtrOut + 1
    Loop

End Sub

To use the code: press Alt-F11. this will bring up the VBA code editor. Go to Insert-module and copy/paste this code into it. You can then either run the code from the excel sheet from the Developer tab-Macro, or put your cursor somewhere in the middle of the code and press f5.

Originally Posted by cjo

First, though, what I meant by "Nice Rectangle" is each company has the same number of rows. That is fairly simple thing to do with formulas. If each company has a different number of rows underneath them, then I can't think of a formula off hand that wouldn't require a clean up using an autofilter.

Sorry I should have been clearer. They have different numbers of rows.

As to the assumptions, I think we've got some tenses confused. In your current sheet, can the company names can be seen in cells A1, M1, Y1, etc?
Also, I'm just leaving the top row blank for the headers. So long as your headers h1, h2, etc don't change value, you should only have to copy/paste it over once.

Close they are currently in B1, O1, AB1 etc. - but they are also in the first column of each table(A3-,N3-, ec.) so perhaps for ease I should remove this first row?

As to some new information you just provided, is your data is currently spread across multiple worksheets? If so, it could be possible to save you some effort. Do the worksheets have some sort of similarity in the names, or some other way to give a good positive identification that they should be included in this cleanup/merge?

They are named the same except numbered 1-14 at the end of the filename, but as I mentioned this is a small number so I don't mind doing them singly.


Tested the macro and it seems very close to doing what I want, although there seems to be an error. Company A's data looks perfect, but for B's the data all shifts one square to the right (and column M goes to column B). After this company there is a string of numbers in the B column, before the next company which is further right-shifted, then string in B & C, then next company further right-shifted etc.
Wish I could troubleshoot this myself but the code looks completely alien to me. Any ideas?


Again massive thanks for the help so far!

Ok,now that one piece of confusion is cleared up (where the company names are held), and I think I've got one other piece of confusion cleared up (the number of columns per item in the original dataset is 13, not 12 as I had on the last revision), we can now get down to business.

I'm going to ask you to change something in the following code. You said that all the sheetnames are the same, except that they are followed by 1, 2, ... ,14. There's a line

If wsInput.Name Like "TheCommonName*" Then

where you should replace the "TheCommonName*" with "Data*" or "Companies*" (notice the star) with whatever is your naming convention -- provided that all worksheets are in the same workbook. If they aren't, you'll need to remove that line, this line

For Each wsInput In ActiveWorkbook.Worksheets

and these two lines at the end.

        End If
    Next wsInput

(make sure that the 'end if' directly above the Next wsInput is removed.
and then, right above

Set wsOutput = Worksheets.Add

put back in

Set wsInput = ActiveSheet

any way, hopefully this won't be a problem, so try this:

Sub FixFourColumnData()
    Dim lCtrIn           As Long
    Dim lCtrOut          As Long
    Dim lColNbr          As Long

    Dim wsInput          As Worksheet
    Dim wsOutput         As Worksheet


    Set wsOutput = Worksheets.Add


    lCtrOut = 2


    For Each wsInput In ActiveWorkbook.Worksheets
        'the next line is where you should put in the text common
        'to all the worksheets you're interested in.  Be sure to
        'use a * for a wildcard where the number would appear.
        If wsInput.Name Like "TheCommonName*" Then
            lColNbr = 1
            lCtrIn = 3
            Do
                'check to see if we're at the end of a col.
                'if so, move over to next group of 13, and reset
                'to the first row of data
                If wsInput.Cells(lCtrIn, lColNbr) = "" Then
                    lColNbr = lColNbr + 13
                    lCtrIn = 3
                    If wsInput.Cells(lCtrIn, lColNbr) = "" Then Exit Do
                    'check to see if the first item in the 13 column group
                    'is blank.  if it's blank, we've ran through the
                    'whole data set for the given company.
                End If

                'copy the info to the output sheet
                wsOutput.Cells(lCtrOut, 1) = wsInput.Cells(1, lColNbr + 1)
                wsOutput.Range(wsOutput.Cells(lCtrOut, 2), wsOutput.Cells(lCtrOut, 14)).Value _
                        = wsInput.Range(wsInput.Cells(lCtrIn, lColNbr), wsInput.Cells(lCtrIn, lColNbr + 12)).Value
                'set the counter to look at the next row on the input sheet.
                lCtrIn = lCtrIn + 1
                'set the counter to output to the next row on the output sheet
                lCtrOut = lCtrOut + 1
            Loop
        End If
    Next wsInput
End Sub