I am new at VBA and trying to figure out how to fill a number series using VBA. The blanks between two numbers can be one or several cells. I want to fill it in a linear way. Note that the percentages can go up or down.
1............2.............3............4............5...............6.
Jan........ 4,34%.......... 4,23%..............blank..............3,21%..............5,31%..................Blank
Feb.... 10.06%...........Blank................Blank............15.41%...........17.35%...................Blank
March...Blank............5.50%..............Blank..............Blank..............7.16%....................13.21%
Every line corresponds to a month for a specific country and every column to the day of the month. So far the macro I have fills the blanks but the numbers I get are wrong and I do not understand why. Plus if there is no number in column B (first day of the month) the macro stops running. Here is a part of the code I am using so far (probably full of errors and not optimized):
Sub FillLinear()
Dim rng As Range
Dim stepValue As Integer
Set rng = Range("B2", Range("B2").End(xlToRight))
On Error Resume Next
Do
'Compute the difference between the first & last cell in the range,
' divided by the number of blank cells + 1.
stepValue = (rng(rng.Cells.Count).Value - rng(1).Value) / _
(rng.SpecialCells(xlCellTypeBlanks).Count + 1)
On Error Resume Next
'now we can use our computed "stepValue" instead of hard-coding it as a constant:
'## Use the resize method to avoid overwriting the last cell in this range
rng.Resize(, rng.Cells.Count - 1).DataSeries Rowcol:=xlRows, _
Type:=xlLinear, _
Date:=xlDay, _
Step:=stepValue, _
Trend:=False
'Increment the range to the next row
Set rng = Range(rng(1).Offset(1), rng(1).Offset(1).End(xlToRight))
'Escape the loop only when we reach an empty/blank cell in the first column:
Loop Until Trim(rng(1).Value) = vbNullString
On Error Resume Next
Set rng = Range("C2", Range("C2").End(xlToRight))
Do
'Compute the difference between the first & last cell in the range,
' divided by the number of blank cells + 1.
stepValue = (rng(rng.Cells.Count).Value - rng(1).Value) / _
(rng.SpecialCells(xlCellTypeBlanks).Count + 1)
On Error Resume Next
'now we can use our computed "stepValue" instead of hard-coding it as a constant:
'## Use the resize method to avoid overwriting the last cell in this range
rng.Resize(, rng.Cells.Count - 1).DataSeries Rowcol:=xlRows, _
Type:=xlLinear, _
Date:=xlDay, _
Step:=stepValue, _
Trend:=False
'Increment the range to the next row
Set rng = Range(rng(1).Offset(1), rng(1).Offset(1).End(xlToRight))
'Escape the loop only when we reach an empty/blank cell in the first column:
Loop Until Trim(rng(1).Value) = vbNullString
On Error Resume Next
Set rng = Range("D2", Range("D2").End(xlToRight))
Do
'Compute the difference between the first & last cell in the range,
' divided by the number of blank cells + 1.
stepValue = (rng(rng.Cells.Count).Value - rng(1).Value) / _
(rng.SpecialCells(xlCellTypeBlanks).Count + 1)
On Error Resume Next
'now we can use our computed "stepValue" instead of hard-coding it as a constant:
'## Use the resize method to avoid overwriting the last cell in this range
rng.Resize(, rng.Cells.Count - 1).DataSeries Rowcol:=xlRows, _
Type:=xlLinear, _
Date:=xlDay, _
Step:=stepValue, _
Trend:=False
'Increment the range to the next row
Set rng = Range(rng(1).Offset(1), rng(1).Offset(1).End(xlToRight))
'Escape the loop only when we reach an empty/blank cell in the first column:
Loop Until Trim(rng(1).Value) = vbNullString
On Error Resume Next
Set rng = Range("E2", Range("E2").End(xlToRight))
Do
'Compute the difference between the first & last cell in the range,
' divided by the number of blank cells + 1.
stepValue = (rng(rng.Cells.Count).Value - rng(1).Value) / _
(rng.SpecialCells(xlCellTypeBlanks).Count + 1)
On Error Resume Next
'now we can use our computed "stepValue" instead of hard-coding it as a constant:
'## Use the resize method to avoid overwriting the last cell in this range
rng.Resize(, rng.Cells.Count - 1).DataSeries Rowcol:=xlRows, _
Type:=xlLinear, _
Date:=xlDay, _
Step:=stepValue, _
Trend:=False
'Increment the range to the next row
Set rng = Range(rng(1).Offset(1), rng(1).Offset(1).End(xlToRight))
'Escape the loop only when we reach an empty/blank cell in the first column:
Loop Until Trim(rng(1).Value) = vbNullString
End Sub
So far I did not find any other solution than copy paste the same code forst every column.
I'd like to suggest a slightly different approach. But that is of course merely personal preference. In this solution I am going through all the cells left to right and top to bottom starting with cell B2 always sampling for empty cells and keeping track of the last cell with a value.
Once an empty range - between two filled cells - has been identified a second sub is called to fille this range. In short, this is the solution I am proposing:
Option Compare Text
Option Explicit
Option Base 0
Public Sub FillLinear()
Dim strLastRange, strToRange As String
Dim intCountBlanks As Integer
Dim lngRow, lngColumn As Long
For lngRow = 2 To 2000000000
If IsEmpty(Cells(lngRow, 1).Value2) Then Exit For
For lngColumn = 2 To 100
If IsEmpty(Cells(1, lngColumn).Value2) Then Exit For
If Cells(lngRow, lngColumn).Value2 = vbNullString Then
If Not strLastRange = vbNullString Then
intCountBlanks = intCountBlanks + 1
End If
Else
If strLastRange = vbNullString Then
strLastRange = Cells(lngRow, lngColumn).Address
Else
If intCountBlanks = 0 Then
strLastRange = Cells(lngRow, lngColumn).Address
Else
strToRange = Cells(lngRow, lngColumn).Address
Call FillThemUp(strLastRange, strToRange, intCountBlanks)
strLastRange = strToRange
End If
End If
intCountBlanks = 0
End If
Next lngColumn
Next lngRow
End Sub
Public Sub FillThemUp(ByVal strLastRange As String, ByVal strToRange As String, ByVal intCountBlanks As Integer)
Dim lngRow, lngColumn As Long
Dim strLastCell As String
Dim lngCountDown As Long
Dim bolStart As Boolean
lngCountDown = intCountBlanks
intCountBlanks = intCountBlanks + 1
For lngRow = 2 To 2000000000
If IsEmpty(Cells(lngRow, 1).Value2) Then Exit For
For lngColumn = 2 To 100
If IsEmpty(Cells(1, lngColumn).Value2) Then Exit For
If lngRow = Range(strLastRange).Row And lngColumn = Range(strLastRange).Column Then bolStart = True
If bolStart = True Then
If IsEmpty(Cells(lngRow, lngColumn).Value2) Then
Cells(lngRow, lngColumn).Formula = "=" & strLastCell & "-((" & strLastRange & "-" & strToRange & ")/" & intCountBlanks & ")"
Cells(lngRow, lngColumn).Interior.ColorIndex = 36
lngCountDown = lngCountDown - 1
End If
strLastCell = Cells(lngRow, lngColumn).Address
End If
If lngCountDown = 0 Then Exit Sub
Next lngColumn
Next lngRow
End Sub