Question

我希望这个问题还没有被提出，但是我找不到任何有关我具体问题的答案。我是VBA的新手，并试图弄清楚如何使用vba填充数字系列。两个数字之间的空白可以是一个或多个单元格。我想以线性的方式填写它。请注意，百分比可以上升或下降。

        1............2.............3............4............5...............6.

Jan ........ 4,34％.......... 4,23％.............. blank ..... ......... 3,21％.............. 5,31％..................空白

2月...... 10.06％...........空白................空白........... .15.41％........... 17.35％...................空白

三月...空白............ 5.50％..............空白............. .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

在数字系列vba中用空格填充线性

1 个答案: