VBA - insert rows with interpolated values

[lotusbalder]

Hi all,

I am extremely bad at VBA.

I would like to run VBA to generate the gap in my raw data and apply an interpolation.

In the first column I have discontinued distances. can by step of 0.5m /1m / 2m / 4m or 8m.
I would like to insert rows by steps of 0.1m and interpolate the values.

The other columns will have various capacities but the challenge is in the fact that my crane won't have the reach and give 0 (minimum or maximum radius).

I hope that my screenshot and explanation is making sense.

Thank you in advance for your help.

 

[Kaper]

Such a macro shall do the job:

Sub LinInterpolate()
Const startcolumn& = 1, startrow& = 2
Dim addedarr As Variant, lr As Long, i As Long, j As Long, k As Long
Dim addedrows As Long, incstep As Double, startval As Double

lr = Cells(Rows.Count, startcolumn).End(xlUp).Row
For i = lr To startrow + 1 Step -1
   addedrows = CLng((Cells(i, startcolumn).Value - Cells(i - 1, startcolumn).Value) * 10)
   Debug.Print i; Cells(i, startcolumn).Value; addedrows
   ReDim addedarr(1 To addedrows - 1, 1 To 4)
   startval = Cells(i - 1, startcolumn).Value
   incstep = 0.1
   For k = 1 To addedrows - 1
     addedarr(k, 1) = startval + k * incstep
   Next k
   For j = 1 To 3
     If Cells(i, startcolumn + j).Value <> "" And Cells(i - 1, startcolumn + j).Value <> "" Then
       startval = Cells(i - 1, startcolumn + j).Value
       incstep = (Cells(i, startcolumn + j).Value - startval) / addedrows
       For k = 1 To addedrows - 1
         addedarr(k, j + 1) = startval + k * incstep
       Next k
     End If
   Next j
   Rows(i).Resize(addedrows - 1).Insert
   With Cells(i, startcolumn).Resize(addedrows - 1, 4)
     .Interior.ColorIndex = 6
     .Value = addedarr
     .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
   End With
Next i
End Sub

PS. If your data header does not start in cell A1 change location where data range starts defined in constants startcolumn and startrow (with header in A1:D1 data starts in A2 - 1st column but 2nd row of the sheet).

 

[lotusbalder]

Hi Kaper,

Thank so much, you are magic.
It is exactly what I was looking for.
The code is short so I will analyse it to start to put my head around VBA.

 

[Kaper]

I tried to use meaningful names of variables, used also two constants for table location to make modifications easier, and the algorithm is indeed pretty simple.

Another concept which comes to my mind is to add all extra rows as one array at the end of current array, paint interior yellow and only as a final touch sort the table using first column as a key. This shall be quicker .

Sub LinInterpolate2()
Const startcolumn& = 1, startrow& = 2
Dim addedarr As Variant, lr As Long, i As Long, j As Long, k As Long
Dim addedrows As Long, incstep As Double, endval As Double, allrows As Long

lr = Cells(Rows.Count, startcolumn).End(xlUp).Row
allrows = 0 'not really needed. allrows will initialize as 0 because it was declared as long
ReDim addedarr(1 To 4, 1 To 1) ' the array will grow dynamically, so has to be rotated (only last dimention can be changed)
For i = startrow + 1 To lr 'no need to go downwards up as we don't insert rows
  If Cells(i, startcolumn).Value - Cells(i - 1, startcolumn).Value > 0.1 Then 'this is needed only if 2 first rows have 0.1 increase
      addedrows = CLng((Cells(i, startcolumn).Value - Cells(i - 1, startcolumn).Value) * 10)
      allrows = allrows + addedrows - 1
      ReDim Preserve addedarr(1 To 4, 1 To allrows)
      endval = Cells(i, startcolumn).Value
      incstep = 0.1
      For k = 1 To addedrows - 1
        addedarr(1, allrows - k + 1) = endval - k * incstep
      Next k
      For j = 1 To 3
        If Cells(i, startcolumn + j).Value <> "" And Cells(i - 1, startcolumn + j).Value <> "" Then
          endval = Cells(i, startcolumn + j).Value
          incstep = (endval - Cells(i - 1, startcolumn + j).Value) / addedrows
          For k = 1 To addedrows - 1
            addedarr(j + 1, allrows - k + 1) = endval - k * incstep
          Next k
        End If
      Next j
  End If
Next i
With Cells(lr + 1, startcolumn).Resize(allrows, 4)
  .Interior.ColorIndex = 6
  .Value = Application.Transpose(addedarr) 'rotating back
End With
Range(Cells(startrow, startcolumn), Cells(lr + allrows, startcolumn + 3)).Sort key1:=Cells(startrow, startcolumn), order1:=xlAscending, Header:=xlNo
End Sub

BTW. I am always more than happy when I encourage someone to analyze the code and learn (that's why I'm working as an associate professor at the university )