如何在数字系列中的空白处填入线性？
How to fill linear in blanks in number series?
我是 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
到目前为止，我没有找到任何其他解决方案，只能为每一列复制粘贴相同的代码。
我想推荐一种稍微不同的方法。但这当然只是个人喜好。在此解决方案中，我将从左到右、从上到下遍历所有单元格，从单元格 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 的新手，正在尝试弄清楚如何使用 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
到目前为止，我没有找到任何其他解决方案，只能为每一列复制粘贴相同的代码。
我想推荐一种稍微不同的方法。但这当然只是个人喜好。在此解决方案中，我将从左到右、从上到下遍历所有单元格，从单元格 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