Insert new rows with increments from existing rows...

[joeallenfm]

Hi MrExcel board, first time poster in need...

I have 600k rows of data like this;

CODE	Product	Quantity	CustomerID
WMB0000025	Medium Thing	25	x35904930
WMX0000240	Small Thing	25	x49509600
WMB0000391	Medium Thing	25	x39409510

I would like to run a script to insert rows after each existing row where:

1. The number of rows inserted is taken from the quantity cell of the row triggering the insert minus 1.
2. The Code of the inserted rows is the same as the code cell from the triggering row + 1 added the the numerical part of the code... e.g. the first two rows after the first example above would be WMB0000026 and WMB0000027.
3. The Product and Customer ID are the same as the cells from the triggering row.
4. The rows are inserted and do not overwrite any existing rows - so in example above the second row of data (WMX0000240) would still be there after the script had executed the first row of data's insert.

 

[joeallenfm]

Ah good spot. I might have to batch it.

 

[HaHoBe]

Hi Flashbond,

I hope it will be fast enough for 600k rows

Not really.

I set up a sheet with a number of Dummies with this code (with 500, 2.500, 5.000, and 100.000 rows of data)

Sub MakeTable()

Dim lngRow As Long
Dim avarArr()

Const clngMax As Long = 100000

ReDim avarArr(1 To clngMax, 1 To 4)

Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sample " & clngMax

For lngRow = 1 To clngMax
  avarArr(lngRow, 1) = "A" & Chr(64 + WorksheetFunction.RandBetween(1, 26)) & _
        Chr(64 + WorksheetFunction.RandBetween(1, 26)) & "d" & _
        Right("00000000" & WorksheetFunction.RandBetween(100000, 500000000), 9)
  avarArr(lngRow, 2) = Choose(WorksheetFunction.RandBetween(1, 3), "Small", "Medium", "Large")
  avarArr(lngRow, 3) = 25
  avarArr(lngRow, 4) = "x" & Right("000000" & WorksheetFunction.RandBetween(1000000, 9999999), 7)
Next lngRow
Range("A2").Resize(clngMax, 4).Value = avarArr
End Sub

I modified your code (as always i is not dimmed) to

Sub test2()
  Dim lRow As Long, r As Long, i As Long
  Dim dblStart As Double, dblEnd As Double
 
  Const clngSample As Long = 500
 
  Worksheets("Sample " & clngSample).Copy after:=Worksheets(Worksheets.Count)
  dblStart = Timer
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  Application.ScreenUpdating = False
  For i = lRow To 2 Step -1
    r = Cells(i, 3).Value - 1
    Rows(i + 1).Resize(r).EntireRow.Insert
    With Range("A" & i & ":B" & i)
    .AutoFill Destination:=.Resize(r + 1)
    End With
    Range("C" & i + 1 & ":D" & i + 1).Resize(r).Value = Range("C" & i & ":D" & i).Value
  Next
  Application.ScreenUpdating = True
  dblEnd = Timer
  Debug.Print "Flashbond number of rows: " & clngSample & ", elapsed seconds: " & dblEnd - dblStart
End Sub

and used this as an alternative code to compare (I choose to start writing to Column H and on if needed):

Sub MrE_1229595_1702911()
' https://www.mrexcel.com/board/threads/insert-new-rows-with-increments-from-existing-rows.1229595/
  Dim lngRow As Long
  Dim lngArr As Long
  Dim lngCnt As Long
  Dim lngLastR As Long
  Dim lngNumber As Long
  Dim lngOffset As Long
  Dim avarArr
  Dim avarOut()

  Dim dblStart As Double, dblEnd As Double
 
  Const clngMax As Long = 750000
  Const clngNextCol As Long = 5
  Const clngSample As Long = 500
 
  Worksheets("Sample " & clngSample).Copy after:=Worksheets(Worksheets.Count)
  lngLastR = Cells(Rows.Count, 1).End(xlUp).Row
  dblStart = Timer
  Application.ScreenUpdating = False
 
  avarArr = Range("A2:D" & lngLastR).Value
  ReDim avarOut(1 To clngMax, 1 To 4)
 
  For lngRow = 1 To UBound(avarArr)
    lngNumber = Right(avarArr(lngRow, 1), 9)
    For lngArr = 1 To avarArr(lngRow, 3)
      lngCnt = lngCnt + 1
      If lngCnt = clngMax Then
        Cells(2, 8 + lngOffset * clngNextCol).Resize(lngCnt, 4).Value = avarOut
        lngOffset = lngOffset + 1
        ReDim avarOut(1 To clngMax, 1 To 4)
        lngCnt = 1
      End If
      avarOut(lngCnt, 1) = Left(avarArr(lngRow, 1), 4) & Format(lngNumber + lngArr, "000000000")
      avarOut(lngCnt, 2) = avarArr(lngRow, 2)
      avarOut(lngCnt, 3) = avarArr(lngRow, 3)
      avarOut(lngCnt, 4) = avarArr(lngRow, 4)
    Next lngArr
  Next lngRow
 
  Cells(2, 8 + lngOffset * clngNextCol).Resize(lngCnt, 4).Value = avarOut

  Application.ScreenUpdating = True
  dblEnd = Timer
  Debug.Print "HaHoBe number of rows: " & clngSample & ", elapsed seconds: " & dblEnd - dblStart
 
End Sub

Results from the Immediate window:

Flashbond number of rows: 500, elapsed seconds: 5,97265625
HaHoBe number of rows: 500, elapsed seconds: 0,046875
Flashbond number of rows: 500, elapsed seconds: 3,02734375
HaHoBe number of rows: 500, elapsed seconds: 0,078125
Flashbond number of rows: 500, elapsed seconds: 5,91796875
HaHoBe number of rows: 500, elapsed seconds: 0,09765625

Flashbond number of rows: 2500, elapsed seconds: 17,6171875
HaHoBe number of rows: 2500, elapsed seconds: 0,12890625
Flashbond number of rows: 2500, elapsed seconds: 16,76953125
HaHoBe number of rows: 2500, elapsed seconds: 0,125
Flashbond number of rows: 2500, elapsed seconds: 30,26171875
HaHoBe number of rows: 2500, elapsed seconds: 0,140625

Flashbond number of rows: 5000, elapsed seconds: 46,49609375
HaHoBe number of rows: 5000, elapsed seconds: 0,22265625
Flashbond number of rows: 5000, elapsed seconds: 65,12109375
HaHoBe number of rows: 5000, elapsed seconds: 0,21484375
Flashbond number of rows: 5000, elapsed seconds: 57,046875
HaHoBe number of rows: 5000, elapsed seconds: 0,21875

HaHoBe number of rows: 100000, elapsed seconds: 40,171875
HaHoBe number of rows: 100000, elapsed seconds: 38,14453125
HaHoBe number of rows: 100000, elapsed seconds: 45,28515625

The increase in time between 5000 and 100000 rows for my code should be due to multiple writings for the code instead of one go for the samples up to 5000. No comparision with your code as error handling was not added although this aspect has been mentioned.

Holger

 

[Legacy 143009]

I also thought of using arrays after posting my original code. One thing I would do different then yours, instead of redimming on every pass, I would set my arraysize at the beginning since the array size will always be equal to sum of column C.

Due to math above, the index of the original values could also be pre-determined. Then, I would do my For Next loops. I should test this theory but it may shave some time.

PS: Yes, I can see no point to dim i other than the situations where Option Explicit has been used.

 

[HaHoBe]

Hi joeallenfm,

I suggest you add one codeline directly beneath the Dims to the code you marked as solution:

  If WorksheetFunction.Sum(ActiveSheet.Columns(3)) >= Rows.Count Then Exit Sub

This line will add up all combinations listed in Column C and quit if the number is equal to or greater as 1.048.576.

Holger

 

[HaHoBe]

Hi Flashbond,

awaiting your solution.

In the meantime I slightly altered the code for creating dummy data (allowing different numbers of rows to be inserted) to

Sub MakeTableMod()

Dim lngRow As Long
Dim avarArr()
Dim oWSF As WorksheetFunction

Const clngMax As Long = 40000

ReDim avarArr(1 To clngMax, 1 To 4)

Set oWSF = Application.WorksheetFunction

Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Sample " & clngMax

For lngRow = 1 To clngMax
  avarArr(lngRow, 1) = "A" & Chr(64 + oWSF.RandBetween(1, 26)) & _
        Chr(64 + oWSF.RandBetween(1, 26)) & "d" & _
        Right("00000000" & oWSF.RandBetween(100000, 500000000), 9)
  avarArr(lngRow, 2) = Choose(oWSF.RandBetween(1, 3), "Small", "Medium", "Large")
  avarArr(lngRow, 3) = oWSF.RandBetween(10, 50)
  avarArr(lngRow, 4) = "x" & Right("000000" & oWSF.RandBetween(1000000, 9999999), 7)
Next lngRow
Range("A2").Resize(clngMax, 4).Value = avarArr

Set oWSF = Nothing
Erase avarArr
End Sub

And I updated the code create new data in order to avoid redimming the array:

Sub MrE_1229595_1702911Update()
' https://www.mrexcel.com/board/threads/insert-new-rows-with-increments-from-existing-rows.1229595/
  Dim lngRow As Long
  Dim lngArr As Long
  Dim lngCnt As Long
  Dim lngLastR As Long
  Dim lngNumber As Long
  Dim lngOffset As Long
  Dim lngNewRows As Long
  Dim avarArr
  Dim avarOut()

  Dim dblStart As Double, dblEnd As Double
  
  Const clngMax As Long = 500000
  Const clngNextCol As Long = 5
  Const clngSample As Long = 100000
  
  Worksheets("Sample " & clngSample).Copy after:=Worksheets(Worksheets.Count)
  dblStart = Timer
  lngLastR = Cells(Rows.Count, 1).End(xlUp).Row
  Application.ScreenUpdating = False
  
  lngNewRows = WorksheetFunction.Sum(ActiveSheet.Columns(3))
  lngOffset = lngNewRows \ clngMax + 1
  ReDim avarOut(1 To clngMax, 1 To 4 * lngOffset)
  lngOffset = 0
  avarArr = Range("A2:D" & lngLastR).Value
  
  For lngRow = 1 To UBound(avarArr)
    lngNumber = Right(avarArr(lngRow, 1), 9)
    For lngArr = 1 To avarArr(lngRow, 3)
      lngCnt = lngCnt + 1
      If lngCnt > clngMax Then
        lngOffset = lngOffset + 1
        lngCnt = 1
      End If
      avarOut(lngCnt, 1 + lngOffset * 4) = Left(avarArr(lngRow, 1), 4) & Format(lngNumber + lngArr, "000000000")
      avarOut(lngCnt, 2 + lngOffset * 4) = avarArr(lngRow, 2)
      avarOut(lngCnt, 3 + lngOffset * 4) = avarArr(lngRow, 3)
      avarOut(lngCnt, 4 + lngOffset * 4) = avarArr(lngRow, 4)
    Next lngArr
  Next lngRow
  
  Cells(2, "A").Resize(clngMax, 4 + lngOffset * 4).Value = avarOut
  Erase avarOut

  Application.ScreenUpdating = True
  dblEnd = Timer
  Debug.Print "HaHoBe Update number of rows original: " & Format(clngSample, "#,##0") & _
      ", number of rows created: " & Format(lngNewRows, "0,000") & _
      ", elapsed seconds: " & dblEnd - dblStart
  
End Sub

I ran both my codes on the new data set as well as on the existing Sample 100000 and got

HaHoBe number of rows: 40000, elapsed seconds: 17,4921875
HaHoBe Update number of rows original: 40.000, number of rows created: 1.199.358, elapsed seconds: 18,83984375

HaHoBe number of rows: 100000, elapsed seconds: 38,37109375
HaHoBe Update number of rows original: 100.000, number of rows created: 2.500.000, elapsed seconds: 35,33203125

Holger

 

[shinigamilight]

So there's no knowing how many rows you'd end up with so I redimmed it to the maximum number of rows. Try this

Sub CCC()
            Application.ScreenUpdating = False
            
            Dim Datar, Finar
            Datar = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row)
            Dim MyVal As String
            Dim k, i, Counter, S As Long
            ReDim Finar(1 To Rows.Count, 1 To 4)
            Dim regex As Object
            Set regex = CreateObject("vbscript.regexp")
            
            With regex
                    .Global = True
                    .Pattern = "\d+"
            
                For k = 1 To UBound(Datar, 1)
                            S = 0
                        For i = 1 To Datar(k, 3)
                            If i = 1 Then Set mc = .Execute(Datar(k, 1))
                            Counter = Counter + 1
                            S = S + 1
                            Finar(Counter, 2) = Datar(k, 2)
                            Finar(Counter, 3) = Datar(k, 3)
                            Finar(Counter, 4) = Datar(k, 4)
                            MyVal = Format(mc(0) + (S - 1), "0000000")
                            MyVal = .Replace(Datar(k, 1), MyVal)
                            Finar(Counter, 1) = MyVal
                        Next i
                Next k
            
          End With
          
           Sheets.Add after:=Sheets(Sheets.Count)
           ActiveSheet.Range("A1").Resize(UBound(Finar, 1), UBound(Finar, 2)) = Finar
          
          Application.ScreenUpdating = True
         
End Sub

 

[HaHoBe]

Hi shiningamilight,

So there's no knowing how many rows you'd end up with so I redimmed it to the maximum number of rows.

Take my advice from Insert new rows with increments from existing rows... and add codeline

  If WorksheetFunction.Sum(ActiveSheet.Columns(3)) >= Rows.Count Then Exit Sub

I added another dummy set with 25,000 rows of Data and result was:

shinigamilight number of rows original: 25.000, number of rows created: 748.355, elapsed seconds: 16,625
HaHoBe number of rows original: 25.000, number of rows created: 748.355, elapsed seconds: 11,8125
HaHoBe Update number of rows original: 25.000, number of rows created: 748.355, elapsed seconds: 12,74609375

Let's assume the rows of Data be 600,000 and the number wanted for each Code 2. I can't imagine a way to get 1,200,000 rows into a sheet if I don't split and pass an upper limit for the number of rows in a split.

Holger

 

[shinigamilight]

16 seconds is not too shabby for my code,

 

[Legacy 143009]

Hi Flashbond,

awaiting your solution.

I marked this post as Unwatch. I refuse to help @HaHoBe to mastrubate his drag race passion.

This is a platform to help people. Not to prove our superiorities.

Anyone may enjoy competitivenes but not me. I don't like to stay in places that I don't feel confortable.