Macro to re-arrange data from x number of columns into x number of rows then copy down data in rows A and B

Question

I have a rather significant amount of data in a spreadsheet that is poorly arranged. The current format has a company, a product name, and the ingredients listed afterwards. The ingredients all have their own column without a header. For instance, and I apologize this is not reflected below since I'm terrible at markup language, Column A would be labeled Manufacturer, Column B would be labeled as Product Name, Column C would be labeled Ingredients but then the rest of the columns are unlabeled.

Ultimately, I need to move the data to a new sheet, where data only appears in columns A, B, and C. The number of ingredients each product has varies.

I hope that the desired format helps.

Current Format:

1| Acme Inc.    | ABC123       | Water       | Sugar     | Eggs    | Salt
2| Acme Inc.    | BCD456       | Cornmeal    | Salt
3| JJ Baking    | JJ4567       | Flour       | Nuts      | Fruit

Desired Format:

1| Acme Inc. | ABC123 | Water
2| Acme Inc. | ABC123 | Sugar
3| Acme Inc. | ABC123 | Eggs
4| Acme Inc. | ABC123 | Salt
5| Acme Inc. | BCD456 | Cornmeal
6| Acme Inc. | BCD456 | Salt
7| JJ Baking | JJ4567 | Flour
8| JJ Baking | JJ4567 | Nuts
9| JJ Baking | JJ4567 | Fruit

score 1 · Answer 1 · answered Nov 04 '15 at 17:35

Here's a short one that should work:

Sub test()
Dim lastRow&, lastCol&, noItems&
Dim i&, k&
' This macro will assume your column A and B are constant, and your items will start in column C
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = lastRow To 1 Step -1
    lastCol = Cells(i, Columns.Count).End(xlToLeft).Column
    noItems = WorksheetFunction.CountA(Range(Cells(i, 3), Cells(i, lastCol)))

    ' Now we know how many items, so add the info to the new rows.
    ' Start with the name and col B
    Range(Cells(i + 1, 1), Cells(i + noItems - 1, 1)).EntireRow.Insert
    Range(Cells(i, 1), Cells(i + noItems - 1, 2)).FillDown
    For k = 1 To noItems - 1
        Cells(i + k, 3).Value = Cells(i, 3 + k).Value
        Cells(i, 3 + k).Value = ""
    Next k

Next i

End Sub

It will look in column C through [whatever column in that row is the last one, going right], then create new rows to fit the amount of items in there.

@user3490381 - If it works for you, do you mind marking as answer? (or if Kris' is better, mark his). If you need any tweaks, just let me know! — BruceWayne, Nov 04 '15 at 18:55

score 0 · Answer 2 · answered Nov 04 '15 at 17:31

This should do the trick, i put my many assumptions in the code comments.

My main one is that there are no gaps between columns with data. EG: Column D is filled out, Column E is blank, Column F is filled out.

Also that there are no 'blank' rows for entries for Column A, and that when we do see a blank row the function stops. Please fill in your 'Worksheet Name' where it says 'Customize to your sheet name'.

Public Sub ReOrder()
    Dim sheet As Worksheet
    Dim row As Integer
    Dim col As Integer
    Dim offset As Integer
    row = 2

    'Customize to your sheet name
    Set sheet = ThisWorkbook.Worksheets("Sheet1")

    'I am assuming there are no 'blanks' between rows or columns
    'If there are such 'blanks' use UsedRange.Rows or UsedRange.Columns
    'Then skip over the blanks with an if statement

    'Keep processing while we see data in the first column
    While (sheet.Cells(row, 1).Value <> "")
        'We only need to make a new row if anything past column C is filled out with something
        col = 4
        offset = 1
        While (sheet.Cells(row, col).Value <> "")
            'Insert new row
            sheet.Rows(row + offset).EntireRow.Insert shift:=xlDown

            'Assign Column values to the new row
            sheet.Cells(row + offset, 1).Value = sheet.Cells(row, 1).Value
            sheet.Cells(row + offset, 2).Value = sheet.Cells(row, 2).Value
            sheet.Cells(row + offset, 3).Value = sheet.Cells(row, col).Value

            'Remove Column value from the source row
            sheet.Cells(row, col).Value = ""

            col = col + 1
            offset = offset + 1
        Wend
        row = row + 1
    Wend
End Sub

Thank you for your response, both macros worked for what I was trying to do! — user3490381, Nov 04 '15 at 18:42

score 0 · Answer 3 · edited May 23 '17 at 12:02

I’m guessing the 3a3n codes are company specific. Assuming ABC1231 is in B1 of Sheet1, insert a new Row1 and apply the technique detailed here, selecting Range in “Step 2b of 3” to be B1: to the end of your data. When you get to the Table you may filter to select and delete the rows blank in Column Value.

In B2 enter:

=INDEX(Sheet3!A:A,MATCH(A4,Sheet3!B:B,0))

Select and Copy Table then Paste Special…, Values over the top and switch the order of Columns A and B.

Macro to re-arrange data from x number of columns into x number of rows then copy down data in rows A and B

3 Answers3