none
Insert Variable Rows Based on Number in ColumnX RRS feed

  • 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

Answers

  • 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 ryguy72 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 ryguy72 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 ryguy72 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 ryguy72 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 ryguy72 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 ryguy72 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