Insert Variable Rows Based on Number in ColumnX

• Question

• I am counting the commas in each cell in ColumnN & columnO.  I’m putting these numbers (the count) in ColumnX.  Now, I’m trying to loop through the records and insert the number of rows, which varies based on the numbers in ColumnX.  If I have a 2 in X2, I want to insert 1 row and copy the entire row from above.  If I have a 10 in X3, I want to insert  9 rows, and copy the data in row 3, 9 times down.

Finally, based on the commas in ColumnN and ColumnO, I want to split the data out to make these unique.  For instance, I have this in N3: 22,16,20

In N3 I want 22, in N4 I want 16, and in N5 I want 20.

I want to do the same in ColumnO.  In O3 I have this: 85,79,83

In O3 I want 85, in O4 I want 79, and in O5 I want 83.

ColumnX is getting the max count of commas in N & O, so I may have 3 commas in a cell in ColumnN and 9 commas in a cell in ColumnO.  Thus, I need to insert copy down 9 rows for ColumnO and 3 for ColumN, and there will be 6 blanks in cells in ColumnN.

Below is the code that I have so far.  I think I’m stuck now.  Does anyone have any thoughts on how to make this work?  I did this in pieces, and bits and pieces seem to work, but it doesn’t all work together.

```Sub concat()
Dim r As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim v As Range
Dim sourceCol, resultRow, resultCol As Integer

Worksheets("Scope Data").Select

LastRow = Cells(65536, 1).End(xlUp).Row
'LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

'Columns("O:P").Select
'Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Range("O1").Select

Range("V1").Value = "Count"
Range("W1").Value = "Count"
Range("X1").Value = "Count"

Range("V2").Select
ActiveCell.FormulaR1C1 = _
"=SUM(LEN(RC[-8]))-SUM(LEN(SUBSTITUTE(RC[-8],"","","""")))+1"
Range("W2").Select
ActiveCell.FormulaR1C1 = _
"=SUM(LEN(RC[-8]))-SUM(LEN(SUBSTITUTE(RC[-8],"","","""")))+1"
Range("W3").Select

ActiveCell.FormulaR1C1 = "=MAX(RC[-2]:RC[-1])"
Range("V2:X2").Select
Selection.AutoFill Destination:=Range("V2:X" & LastRow)

'Set sht = ThisWorkbook.Worksheets("Scope Data")
'Set r = Worksheets("Sheet1").Range("N2:N" & LastRow)

'Insert variable number of rows
Dim myRow As Long

lastcell = Cells(Rows.Count, "X").End(xlUp).Row

myRow = 2
Do Until myRow = lastcell
For i = 1 To Cells(myRow, 24)

If Cells(myRow, 24) <> "" Then
Cells(myRow + 1, 24).Select
ActiveCell.EntireRow.Select
Selection.Copy
Selection.Insert Shift:=xlDown
End If
myRow = myRow + 1
Next
lastcell = Cells(Rows.Count, "X").End(xlUp).Row

Loop

sourceCol = 20
resultRow = 21
resultCol = 22

Dim substr() As String

For Each v In r

substr = Split(v, ",")
numpart = Sheet1.Cells(v.Row, sourceCol).Value
For i = LBound(substr) To UBound(substr)
Sheet1.Cells(resultRow, resultCol) = numpart & "  " & substr(i)
resultRow = resultRow + 1
Next
Next
End Sub

```

Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

Thursday, October 15, 2015 5:27 PM

• Try this:

```Sub SplitData()
Dim r As Long
Dim m As Long
Dim arrN() As String
Dim arrO() As String
Dim uN As Long
Dim uO As Long
Dim u As Long
Dim i As Long
Application.ScreenUpdating = False
m = Range("N:O").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For r = m To 2 Step -1
arrN = Split(Range("N" & r).Value, ",")
uN = UBound(arrN)
arrO = Split(Range("O" & r).Value, ",")
uO = UBound(arrO)
u = uN
If uO > uN Then
u = uO
End If
If u > 0 Then
For i = u To 1 Step -1
Range("A" & r).EntireRow.Copy
Range("A" & (r + 1)).EntireRow.Insert
Next i
Range("N" & r).Resize(u + 1, 2).ClearContents
If uN > -1 Then
Range("N" & r).Resize(uN + 1, 1).Value = Application.Transpose(arrN)
End If
If uO > -1 Then
Range("O" & r).Resize(uO + 1, 1).Value = Application.Transpose(arrO)
End If
End If
Next r
Application.ScreenUpdating = True
End Sub```

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Thursday, October 15, 2015 9:39 PM
Thursday, October 15, 2015 7:46 PM
• Does it make a noticeable difference if you replace

For i = u To 1 Step -1
Range
("A" & r).EntireRow.Copy
Range
("A" & (r + 1)).EntireRow.Insert

Next i

with

Range("A" & (r + 1)).Resize(u, 1).EntireRow.Insert
Range("A" & r).EntireRow.Copy Destination:=Range("A" & (r + 1)).Resize(u, 1)

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Thursday, October 15, 2015 9:51 PM
Thursday, October 15, 2015 9:43 PM
• In that case, there is little to be gained by using SpecialCells(xlCellTypeConstants) - it's the splitting of data that takes time.

You might try turning off automatic calculations and disabling event handling at the beginning of the macro, and restoring the original settings at the end. Depending on how many formulas you have it may or may not make a difference.

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Friday, October 16, 2015 3:08 PM
Friday, October 16, 2015 2:21 PM

All replies

• Try this:

```Sub SplitData()
Dim r As Long
Dim m As Long
Dim arrN() As String
Dim arrO() As String
Dim uN As Long
Dim uO As Long
Dim u As Long
Dim i As Long
Application.ScreenUpdating = False
m = Range("N:O").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For r = m To 2 Step -1
arrN = Split(Range("N" & r).Value, ",")
uN = UBound(arrN)
arrO = Split(Range("O" & r).Value, ",")
uO = UBound(arrO)
u = uN
If uO > uN Then
u = uO
End If
If u > 0 Then
For i = u To 1 Step -1
Range("A" & r).EntireRow.Copy
Range("A" & (r + 1)).EntireRow.Insert
Next i
Range("N" & r).Resize(u + 1, 2).ClearContents
If uN > -1 Then
Range("N" & r).Resize(uN + 1, 1).Value = Application.Transpose(arrN)
End If
If uO > -1 Then
Range("O" & r).Resize(uO + 1, 1).Value = Application.Transpose(arrO)
End If
End If
Next r
Application.ScreenUpdating = True
End Sub```

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Thursday, October 15, 2015 9:39 PM
Thursday, October 15, 2015 7:46 PM
• Wow!!  Super cool!!  This is amazing!!  The ONLY problem is, the data set is quite large, and the script is taking a loooooooong time to run.  Is there any way to speed it up?  I can't think of anything offhand.

Thanks!!

Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

Thursday, October 15, 2015 9:39 PM
• Does it make a noticeable difference if you replace

For i = u To 1 Step -1
Range
("A" & r).EntireRow.Copy
Range
("A" & (r + 1)).EntireRow.Insert

Next i

with

Range("A" & (r + 1)).Resize(u, 1).EntireRow.Insert
Range("A" & r).EntireRow.Copy Destination:=Range("A" & (r + 1)).Resize(u, 1)

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Thursday, October 15, 2015 9:51 PM
Thursday, October 15, 2015 9:43 PM
• Unfortunately, no.

Thanks though!  This is very, very, very useful!  I'll have to fire it off before I go to lunch, that's all.

Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

Thursday, October 15, 2015 9:51 PM
• I wonder if SpecialCells would speed it up.  A long time ago I converted a slow loop, from this . . .

```For Each cell In Rng
If cell.Value <> "" Then
ActiveCell.Offset(0, 7).Select
ActiveCell.FormulaR1C1 = _
"=IF(RIGHT(RC[-2],1)=""N"",""SWAP"",IF(RIGHT(RC[-2],1)=""M"",""SWAP"",IF(RIGHT(RC[-2],2)=""NI"",""SWAP"")))"
ActiveCell.Offset(1, -7).Select
End If
Next cell
```

Into this . . .

```Range(Cells(2, 1), Cells(Range("A65536").End(xlUp).Row, 1)).SpecialCells(xlCellTypeConstants) _
.Offset(0, 7).FormulaR1C1 = _
"=IF(RIGHT(RC[-2],1)=""N"",""SWAP"",IF(RIGHT(RC[-2],1)=""M"",""SWAP"",IF(RIGHT(RC[-2],2)=""NI"",""SWAP"")))"
```

I'm not sure how to implement that logic in this current scenario.  Do you know, Hans?

Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

Thursday, October 15, 2015 10:35 PM
• Do you have lots of empty cells in columns N and O?

Regards, Hans Vogelaar (http://www.eileenslounge.com)

Friday, October 16, 2015 7:57 AM
• No, there are only 69 blanks out of 5966 records.

This is the real problem:

1,2,3,4,5,6,7,8,9,10,11,12,13,14,23,15,16,17,18,19,20,21,22,44,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,41,42,43,39,40

I have a whole bunch of rows like that.  So the loop has to work pretty damn hard.

Thanks for all the help with this!!

Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

Friday, October 16, 2015 2:15 PM
• In that case, there is little to be gained by using SpecialCells(xlCellTypeConstants) - it's the splitting of data that takes time.

You might try turning off automatic calculations and disabling event handling at the beginning of the macro, and restoring the original settings at the end. Depending on how many formulas you have it may or may not make a difference.

Regards, Hans Vogelaar (http://www.eileenslounge.com)

• Marked as answer by Friday, October 16, 2015 3:08 PM
Friday, October 16, 2015 2:21 PM
• That's exactly it.  There are a lot of formulas in several sheets in the whole workbook.  I copied that one sheet that I need, to a new workbook, closed the original workbook, and ran the Macron ONLY on that 1 sheet.  It finished in just 1/2 minute, instead of over 1 hour!!  Amazing!!

I tried to turn off AutoCalculate, and do the calculations ONLY on that one sheet, and it was still really slow.  I didn't expect that.  I thought you could isolate the calculation to a single sheet, or even to a range on one sheet, but it didn't seem to work.  Anyway, it just take an extra minute to isolate that one sheet, run the script, and then add that sheet back to the original workbook.

Thanks so much!!

Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

Friday, October 16, 2015 3:08 PM