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
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.
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
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.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.