如何在数列中填充线性空格？

Question

我在VBA是个新手，我想弄清楚如何用VBA来填充一个数字系列。两个数字之间的空格可以是一个或多个单元格。我想用线性的方式来填充它。请注意，百分比可以上升或下降。

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%

每一行对应于特定国家的一个月，每一列对应于该月的某一天。到目前为止，宏填补了空白，但我得到的数字是错误的，我不明白为什么。此外，如果B列(月的第一天)中没有数字，则宏将停止运行。下面是我到目前为止使用的代码的一部分(可能充满了错误而没有优化)：

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

到目前为止，除了为每一列复制粘贴相同的代码之外，我没有找到任何其他解决方案。

Answer 1

我想提出一个稍微不同的方法。但这当然只是个人的偏好。在这个解决方案中，我将遍历所有的单元，从左到右，从上到下，从单元格B2开始，始终对空单元进行采样，并用值跟踪最后一个单元格。

一旦一个空范围-在两个填充的单元格之间-已经被识别，第二个子调用来填充这个范围。简而言之，这就是我提出的解决办法：

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