Creating new rows based on cell contents

imimin

imimin

Active Member
Joined
May 9, 2006
Messages
404
Hello!

I need help with creating a new macro. I think this might be a challenging macro to write (or should I say easy for some of you pros out there :-) if you are up to the challenge)! Any help on this will be GREATLY APPRECIATED and I will owe you!!!

I have a LARGE list of items that each have an “item Number” (column A), “Description”(column B) and a “size/price” field (column C). Most of the items have a single price. However, about 2,000+/- of the items have 2 or more sizes/prices. See table below:

Excel Workbook
ABC
111214314KY PRIN DIA CHANN BRIDAL SET D.75TW$887.24;
211214714KW MATCHING BAND TO 112147 D.37CTWsize:SW - $1,402.73;size:W - $532.29;
311186914KW MACHINE SET RBC ETER.BAND D.50TW SIZE 7size:6 - $424.44;size:6.5 - $424.44;size:7 - $424.44;
Sheet1


What I need to do is have a macro that will ‘examine’ column C (Size/Price) and do the following:

1) If there is only one price (such as ‘5.00;’ – notice the semicolon after the price and also notice that a size is not associated with the price if there is only one price), then do nothing and move on to the next line.
2) If the column C has more than 1 size/price (such as ‘size:SW - $1,402.73;size:W - $532.29;’) then it needs to add new rows under that row equivalent in number to the number of size/price combos. The item number for the new row(s) will be the same as the one above it followed by a hyphen and the numeric portion of the size (such as 123456-5.5). The ‘Description’ will be copied exactly as the line above it. The size/price (column C) will reflect the size/price for each new item number (such as ‘size:SW - $1,402.73;’ for the first new item number/row and ‘size:W - $532.29;’ for the next new item number/row).
3) This process continues until the end of the data (until the last row in column A (or B or C or whatever) that contains data)

Please see an example of what I am after for an output below:

Excel Workbook
ABC
811214314KY PRIN DIA CHANN BRIDAL SET D.75TW$887.24;
911214714KW MATCHING BAND TO 112147 D.37CTWsize:SW - $1,402.73;size:W - $532.29;
10112147-SW14KW MATCHING BAND TO 112147 D.37CTWsize:SW - $1,402.73;
11112147-W14KW MATCHING BAND TO 112147 D.37CTWsize:W - $532.29;
1211186914KW MACHINE SET RBC ETER.BAND D.50TWsize:6 - $424.44;size:6.5 - $424.44;size:7 - $424.44;
13111869-614KW MACHINE SET RBC ETER.BAND D.50TWsize:6 - $424.44;
14111869-6.514KW MACHINE SET RBC ETER.BAND D.50TW6.5 - $424.44;
15111869-714KW MACHINE SET RBC ETER.BAND D.50TWsize:7 - $424.44;
Sheet1


Thank you VERY MUCH and have a GREAT day!
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
I noticed I left the semi-colons showing on my output example in "column C" (second sample spreed sheet). Of course I DON'T NEED those in the ACTUAL output (it's probably needed as a delimiter). :-) !

Thanks Guys!
 
Last edited:
Upvote 0
imimin,


Sample data before the macro:


Excel Workbook
ABC
111214314KY PRIN DIA CHANN BRIDAL SET D.75TW$887.24;
211214714KW MATCHING BAND TO 112147 D.37CTWsize:SW - $1,402.73;size:W - $532.29;
311186914KW MACHINE SET RBC ETER.BAND D.50TW SIZE 7size:6 - $424.44;size:6.5 - $424.44;size:7 - $424.44;
4
5
6
7
8
9
Sheet1





After the macro:


Excel Workbook
ABC
111214314KY PRIN DIA CHANN BRIDAL SET D.75TW$887.24;
211214714KW MATCHING BAND TO 112147 D.37CTWsize:SW - $1,402.73;size:W - $532.29;
3112147-SW14KW MATCHING BAND TO 112147 D.37CTWsize:SW - $1,402.73;
4112147-W14KW MATCHING BAND TO 112147 D.37CTWsize:W - $532.29;
511186914KW MACHINE SET RBC ETER.BAND D.50TW SIZE 7size:6 - $424.44;size:6.5 - $424.44;size:7 - $424.44;
6111869-614KW MACHINE SET RBC ETER.BAND D.50TW SIZE 7size:6 - $424.44;
7111869-6.514KW MACHINE SET RBC ETER.BAND D.50TW SIZE 7size:6.5 - $424.44;
8111869-714KW MACHINE SET RBC ETER.BAND D.50TW SIZE 7size:7 - $424.44;
9
Sheet1





Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.


Code: 
Option Explicit
Sub ExpandData()
' hiker95, 04/20/2011
' http://www.mrexcel.com/forum/showthread.php?t=544963
Dim LR As Long, a As Long, aa As Long, Sp, s As Long, ss As Long, H As String
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For a = LR To 1 Step -1
  s = Len(Cells(a, 3)) - Len(Application.Substitute(Cells(a, 3), ";", ""))
  If s > 1 Then
    Sp = Split(Cells(a, 3), ";")
    s = UBound(Sp)
    Rows(a + 1).Resize(s).Insert
    Rows(a).Copy Rows(a + 1).Resize(s)
    ss = 0
    For aa = a + 1 To a + s Step 1
      Cells(aa, 3) = Sp(ss) & ";"
      H = Mid(Cells(aa, 3), Application.Find(":", Cells(aa, 3), 1) + 1, Application.Find(" ", Cells(aa, 3), 1) - Application.Find(":", Cells(aa, 3), 1) - 1)
      Cells(aa, 1) = Cells(aa, 1) & "-" & H
      ss = ss + 1
    Next aa
  End If
Next a
Application.ScreenUpdating = True
End Sub


Then run the ExpandData macro.
 
Upvote 0
ok so before I leave this is what I've come up with. Probably needs a few more things tweaked.

Code: 
Sub Add_SWRows()
Dim LR As Long
Application.ScreenUpdating = False
LR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
    MCC = Len(Cells(i, 3)) - Len(Application.WorksheetFunction.Substitute(Cells(i, 3).Value, ";", ""))
    If MCC > 1 Then
        Rows(i).Offset(MCC).EntireRow.Insert
        Cells(i, 1).Copy Destination:=Range(Cells(i + 1, 1), Cells(i, 1).Offset(MCC, 0))
        Cells(i, 2).Copy Destination:=Range(Cells(i + 1, 2), Cells(i, 2).Offset(MCC, 0))
        Cells(i, 3).Copy Destination:=Cells(i + 1, 4)
    End If
'create text to columns and paste transpose
     xx = IsError(Application.Find("|", Application.Substitute(Cells(i, 3).Value, ":", "|")))
    If xx = True Then GoTo 0
    MCC1 = Application.WorksheetFunction.Find("|", Application.WorksheetFunction.Substitute(Cells(i, 3).Value, ":", "|")) + 1
    MCC2 = Application.WorksheetFunction.Find("|", Application.WorksheetFunction.Substitute(Cells(i, 3).Value, "-", "|")) + 2
    Cells(i + 1, 4).TextToColumns Destination:=Cells(i + 1, 4), DataType:=xlDelimited, _
        ConsecutiveDelimiter:=False, Semicolon:=True
    LC = Range("IV" & i + 1).End(xlToLeft).Column
    Range(Cells(i + 1, 4), Cells(i + 1, LC)).Copy
    Cells(i + 1, 3).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Range(Cells(i + 1, 4), Cells(i + 1, LC)).Clear
    MCC3 = Cells(i + 1, 1).Text
    MCC4 = Cells(i + 1, 3).Address(False, False)
0
Next i
MsgBox "Done"
Application.ScreenUpdating = True
End Sub
 
Upvote 0
WOW!
WOW!
WOW!
You guys are GREAT! Thank you so much for your help! Hiker95, your code works perfectly and Texasalynn your code has a definite GOOD start! Like you said, it needs a little tweaking. I REALLY APPRECIATE THE TIME YOU GUYS PUT IN TO THIS! I feel indebted to both of you! It would really be great if more people in the world gave of their time and resources like so many do on this forum!
 
Upvote 0
PROBLEMS ON THE RISE!

hiker95 said:
imimin,

Code: 
Option Explicit
Sub ExpandData()
' hiker95, 04/20/2011
' http://www.mrexcel.com/forum/showthread.php?t=544963
Dim LR As Long, a As Long, aa As Long, Sp, s As Long, ss As Long, H As String
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For a = LR To 1 Step -1
  s = Len(Cells(a, 3)) - Len(Application.Substitute(Cells(a, 3), ";", ""))
  If s > 1 Then
    Sp = Split(Cells(a, 3), ";")
    s = UBound(Sp)
    Rows(a + 1).Resize(s).Insert
    Rows(a).Copy Rows(a + 1).Resize(s)
    ss = 0
    For aa = a + 1 To a + s Step 1
      Cells(aa, 3) = Sp(ss) & ";"
      H = Mid(Cells(aa, 3), Application.Find(":", Cells(aa, 3), 1) + 1, Application.Find(" ", Cells(aa, 3), 1) - Application.Find(":", Cells(aa, 3), 1) - 1)
      Cells(aa, 1) = Cells(aa, 1) & "-" & H
      ss = ss + 1
    Next aa
  End If
Next a
Application.ScreenUpdating = True
End Sub
Click to expand...

Hiker,

Upon further testing of your macro, I ran into a few problems! When I run it against test data of 6,000+ rows, it runs for a few seconds then stops with a MSVB error:

Run-time error '13':
Type mismatch

If I click on the 'Debug' button, line 5 of your code is highlighted in yellow which is :

Code: 
s = Len(Cells(a, 3)) - Len(Application.Substitute(Cells(a, 3), ";", ""))

Another ODD thing that is happening is every so often (between every 3-6 time) if I close the spreed sheet after it has failed, choose not to save it, I get the following error (seems strange to me):

Microsoft Excel
"The picture is too large and will be truncated."

I have to press the 'OK' button twice before the program (Excel) will close. It seems that most of the time this does not happen. WHAT IMAGE!
 
Upvote 0
imimin,

I would gues that there are entries in column C that do not contain ; characters.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


Code: 
Option Explicit
Sub ExpandDataV2()
' hiker95, 04/21/2011
' http://www.mrexcel.com/forum/showthread.php?t=544963
Dim LR As Long, a As Long, aa As Long, Sp, s As Long, ss As Long, H As String
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For a = LR To 1 Step -1
  On Error GoTo ErrorSkip
  s = Len(Cells(a, 3)) - Len(Application.Substitute(Cells(a, 3), ";", ""))
  If s > 1 Then
    Sp = Split(Cells(a, 3), ";")
    s = UBound(Sp)
    Rows(a + 1).Resize(s).Insert
    Rows(a).Copy Rows(a + 1).Resize(s)
    ss = 0
    For aa = a + 1 To a + s Step 1
      Cells(aa, 3) = Sp(ss) & ";"
      H = Mid(Cells(aa, 3), Application.Find(":", Cells(aa, 3), 1) + 1, Application.Find(" ", Cells(aa, 3), 1) - Application.Find(":", Cells(aa, 3), 1) - 1)
      Cells(aa, 1) = Cells(aa, 1) & "-" & H
      ss = ss + 1
    Next aa
  End If
ErrorSkip:
  On Error GoTo 0
Next a
Application.ScreenUpdating = True
End Sub


Then run the ExpandDataV2 macro.


If the problem persists, can we have a screenshot of the row of data where the macro failed?
 
Upvote 0
Thanks Hiker(or would you rather be called HIker95 or something else?) !

V2 seems to work well! I have a few questions:

The only difference I can see is the ErrorSkip line (and its reference) (lines 5, 20 and 21). Are you saying here GoTo line 0 or what? And what happens then? How does that make this work so well? As your script is now, is all my data being created properly when it finds more than one size/price combo? You said

I would guess that there are entries in column C that do not contain ; characters.
Click to expand...

Does that mean if the data in that field is not being delimited correctly that I would be potentially loosing data (i.e. some of my new rows are not being created correctly by your macro?)?
 
Upvote 0
If some of the ';' is missing or just not there in some of my cells, is there a way I could run a test on column C to find out what the other character might be being used instead of the ';' or to see where it is missing?
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Using VBA to select a color coded cell
2
Replies
11
Views
948
Alex Blakenburg
A
S
  • Question Question
Excel VBA to create multi rows based on column header
Replies
1
Views
444
bebo021999
B
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
823
Agnarr
Agnarr
S
  • Solved
For each row, create new folder based on single cell value, then save exported XML doc to matching folder.
Replies
3
Views
684
shand
S
T
  • Solved
Create new workbooks based on cell content?
2
Replies
12
Views
782
kevin9999
K

Forum statistics

Threads
1,224,505
Messages
6,179,151
Members
452,891
Latest member
JUSTOUTOFMYREACH

Share this page

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