Inserting Rows based on cell differences and interpolating in between

[unknown_mem]

Hello -

I have a complicated issue. I have a file with 5 columns (A, B, C, D, E).
A is fixed string value.
B is a number increasing irregularly.
C, D, E, are given values.

What I need to do is have column B regular (i.e. every 1). So I have to insert rows between B i.e.(B2-B1) will determine how many rows between B1 & B2 and then (B3-B2) will determine how many rows between B2 & B3 and so on.
After inserting the rows, I have to linear interpolate columns C, D & E in the newly created empty rows. In all cases I want to keep the original values and interpolate between them.

The other issue is that column B has decimal/fraction, but I think I can round this to the nearest integer to make it easier for interpolation.



Option ExplicitSub Test01()
Application.ScreenUpdating = False
Dim numRows As Long
Dim r As Long
Dim Rng As Range
Dim lastrw As Long
Dim Ar As Range
Dim StepValue1
Dim StepValue2
Dim StepValue3
Dim Ar1 As Range
Dim AR2 As Range

Dim i As Integer
lastrw = Cells(Rows.Count, "A").End(xlUp).Row

i = 1
For i = i + 0 To lastrw Step 1

Set Rng = Range(Cells(i, "A"), Cells(lastrw, "A"))
numRows = Cells(i + 1, 2).Value - Cells(i + 0, 2).Value

For r = Rng.Rows.Count To 1 Step -1
Rng.Rows(r + i).Resize(numRows - 1).EntireRow.Insert
Next r
Next i

Set Rng = Columns(1).SpecialCells(xlBlanks)
For Each Ar In Rng.Areas
Set Ar1 = Ar.Offset(-1, 0).Resize(Ar.Rows.Count + 1)
Set AR2 = Ar1.Resize(Ar1.Rows.Count + 1)

StepValue1 = (AR2(AR2.Count).Offset(0, 2) - _
Ar1(1).Offset(0, 2)) / Ar1.Count

StepValue2 = (AR2(AR2.Count).Offset(0, 3) - _
Ar1(1).Offset(0, 3)) / Ar1.Count

StepValue3 = (AR2(AR2.Count).Offset(0, 4) - _
Ar1(1).Offset(0, 4)) / Ar1.Count

Ar1.Offset(0, 2).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=StepValue1, Trend:=False

Ar1.Offset(0, 3).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=StepValue2, Trend:=False

Ar1.Offset(0, 4).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=StepValue3, Trend:=False

Next
End Sub

[unknown_mem]

Example Input 16915

Desired output: 16916

[snb]

Please post a sample Excel file instead of pictures.
Why should you bother helpers with creating a workbook you already have available ?

[unknown_mem]

Sorry!
Here it is.

[p45cal]

try on your test file:
Sub blah()
'Application.ScreenUpdating = False
Dim numRows As Long, lastrw As Long, i As Long
lastrw = Cells(Rows.Count, "A").End(xlUp).Row
Cells(lastrw, 2).Value = Round(Cells(lastrw, 2).Value, 0) 'round bottom-most value' not sure if this is when you want to do the rounding in column B
For i = lastrw To 2 Step -1
Cells(i - 1, 2).Value = Round(Cells(i - 1, 2).Value, 0) 'not sure if this is when you want to do the rounding in column B
numRows = Cells(i, 2).Value - Cells(i - 1, 2).Value
Rows(i).Resize(numRows - 1).Insert
Cells(i - 1, 2).Resize(numRows + 1, 4).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Trend:=True
Next i
Range(("A1"), Cells(Rows.Count, "A").End(xlUp)).Value = Range("A1").Value
'Application.ScreenUpdating = True
End Sub

[p45cal]

oh groan, you've cross posted wholesale without telling people:
http://www.mrexcel.com/forum/excel-questions/959346-inserting-rows-based-cell-differences-interpolating-between.html
https://groups.google.com/forum/#!topic/microsoft.public.excel.programming/gjmgjk3KyU8
http://www.excelbanter.com/showthread.php?t=451909
http://www.ozgrid.com/forum/showthread.php?t=200863

Any more?

All forums have similar rules/netiquette; you really should include links to all cross posts.
Have a read of http://www.excelguru.ca/content.php?184

[unknown_mem]

Thank you very much p45cal. It worked perfectly, but it gives: Run time error"1004" after completing.
Here's the full code:



Option Explicit
Sub Test01()
Application.ScreenUpdating = False


Dim r As Long
Dim Rng As Range


Dim Ar As Range
Dim StepValue1
Dim StepValue2
Dim StepValue3
Dim Ar1 As Range
Dim AR2 As Range

'Application.ScreenUpdating = False
Dim numRows As Long, lastrw As Long, i As Long
lastrw = Cells(Rows.Count, "A").End(xlUp).Row
Cells(lastrw, 2).Value = Round(Cells(lastrw, 2).Value, 0) 'round bottom-most value' not sure if this is when you want to do the rounding in column B
For i = lastrw To 2 Step -1
Cells(i - 1, 2).Value = Round(Cells(i - 1, 2).Value, 0) 'not sure if this is when you want to do the rounding in column B
numRows = Cells(i, 2).Value - Cells(i - 1, 2).Value
Rows(i).Resize(numRows - 1).Insert
Cells(i - 1, 2).Resize(numRows + 1, 4).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Trend:=True
Next i
Range(("A1"), Cells(Rows.Count, "A").End(xlUp)).Value = Range("A1").Value
'Application.ScreenUpdating = True

Set Rng = Columns(1).SpecialCells(xlBlanks)
For Each Ar In Rng.Areas
Set Ar1 = Ar.Offset(-1, 0).Resize(Ar.Rows.Count + 1)
Set AR2 = Ar1.Resize(Ar1.Rows.Count + 1)

StepValue1 = (AR2(AR2.Count).Offset(0, 2) - _
Ar1(1).Offset(0, 2)) / Ar1.Count

StepValue2 = (AR2(AR2.Count).Offset(0, 3) - _
Ar1(1).Offset(0, 3)) / Ar1.Count

StepValue3 = (AR2(AR2.Count).Offset(0, 4) - _
Ar1(1).Offset(0, 4)) / Ar1.Count

Ar1.Offset(0, 2).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=StepValue1, Trend:=False

Ar1.Offset(0, 3).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=StepValue2, Trend:=False

Ar1.Offset(0, 4).DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, Date:=xlDay, _
Step:=StepValue3, Trend:=False

Next
End Sub

[unknown_mem]

I didn't read the rules to be honest. Sorry about that. I will edit the posts and include the related posts.
I apologize if that was not a proper thing to do.
---Can't add the links here----

[p45cal]

You don't need any code after 'Application.ScreenUpdating=True.

[unknown_mem]

Thanks again for your help. It works now without any errors.

[p45cal]

You don't need any code after 'Application.ScreenUpdating=True.…nor before 'Application.ScreenUpdating=False.

[unknown_mem]

Thanks p45cal .Also i tried the code if I have -ve values in column B and works perfectly.
But i noticed that if the difference between the values is equal to 1 or less the code stops at that row. Is there a way we can skip not inserting rows at this condition and continue to the next rows?

[p45cal]

try:
Sub blah()
'Application.ScreenUpdating = False
Dim numRows As Long, lastrw As Long, i As Long
lastrw = Cells(Rows.Count, "A").End(xlUp).Row
Cells(lastrw, 2).Value = Round(Cells(lastrw, 2).Value, 0) 'round bottom-most value' not sure if this is when you want to do the rounding in column B
For i = lastrw To 2 Step -1
Cells(i - 1, 2).Value = Round(Cells(i - 1, 2).Value, 0) 'not sure if this is when you want to do the rounding in column B
numRows = Cells(i, 2).Value - Cells(i - 1, 2).Value
If numRows > 1 Then
Rows(i).Resize(numRows - 1).Insert
Cells(i - 1, 2).Resize(numRows + 1, 4).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Trend:=True
End If
Next i
Range(("A1"), Cells(Rows.Count, "A").End(xlUp)).Value = Range("A1").Value
'Application.ScreenUpdating = True
End Sub

[unknown_mem]

Yeah that works, I will end up with duplicate values in column B (I will try to figure out which row of them I should keep). Many thanks p45cal. I do appreciate your help.

[unknown_mem]

Hi p45cal

I found out that I need the decimal/fraction.
I have multiplied column B by 100 then I ran the code you provided.
Then I created the following formula "=MOD(ROW(A1)-1,100)=0" to filter every 100.
Then I divided column by 100 again to retain the original values.
Then I have deleted all the hidden rows, but this is taking a lot of time since I have +90 worksheets.


The reason I did this is because when I do the rounding, the interpolation is not accurate and I can't use column B with any fractions/decimals.

A bonus would be if I can loop this for all worksheets inside the file, I tried doing this through calling function but it didn't work..

[p45cal]

1 question: do the values in column B ALWAYS increase as you go down?

[unknown_mem]

I have reviewed most of the sheets and yes they increase. However some sheets start with -ve values (i.e. -33, -30, -26...etc).

[p45cal]

Doing it your way is straightforward and handles many possibilities correctly although it does take time. Here's your way coded. Take a careful note of the comments in the code re which sheets are processed. It works on the active workbook, so make sure that is active before you run macro zz which calls the other:
Sub blah3()
Range("H1") = 100
Range("H1").Copy
Range("A1").CurrentRegion.Columns(2).PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply

Dim numRows As Long, lastrw As Long, i As Long
lastrw = Cells(Rows.Count, "A").End(xlUp).Row
For i = lastrw To 2 Step -1
numRows = Cells(i, 2).Value - Cells(i - 1, 2).Value
If numRows > 1 Then
Rows(i).Resize(numRows - 1).Insert
Cells(i - 1, 2).Resize(numRows + 1, 4).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Trend:=True
End If
Next i
Range(("A1"), Cells(Rows.Count, "A").End(xlUp)).Value = Range("A1").Value

Range("H1") = 100
Range("H1").Copy
Range("A1").CurrentRegion.Columns(2).PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide
Range("A1").CurrentRegion.Columns(1).Offset(, 5).FormulaR1C1 = "=INT(RC[-4])=RC[-4]"
Rows("1:1").Insert
Range("A1:F1").Value = "hdr"
Range("A1").AutoFilter field:=6, Criteria1:="FALSE"
Range("A1").CurrentRegion.Columns(6).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Range("H1").Clear
Columns("F:G").Clear
End Sub
Sub zz()
'Application.ScreenUpdating = False
For Each sht In ActiveWorkbook.Sheets
If Not (sht.Name = "Test01" Or sht.Name = "Sheet2" Or sht.Name = "Sheet1") Then 'adjust this line to include ALL sheets you do not want to be processed.
sht.Activate
blah3
End If
Next sht
'Application.ScreenUpdating = True
End Sub
You can run blah3 on its own if the active sheet is the single sheet you want to process.

[unknown_mem]

Many thanks p45cal. I ran it and it is working perfectly. I will examine all the results thoroughly but it looks perfect.
The amount of time that the macro took to run is indicator to the time saved versus doing it manually. Thanks again for your help.