使用VBA跨单元格分配值

fanjy

发布于 2023-08-29 21:11:10

2970

发布于 2023-08-29 21:11:10

文章被收录于专栏：完美Excel

标签：VBA

这是在exceloffthegrid.com中看到的一个案例，一个非常有用的节省时间的宏：在单元格之间分配值。

假设有一份单个物品的清单，加起来总共210美元，你的老板想额外增加21美元作为应急费用。你打算如何使总额达到231美元？有几个选项：

1.添加一个含有21美元的调整行

2.确定可以增加的具体额度，以达到231美元的总额

3.将21美元的涨幅平均分摊到所有单元格

4.将21美元分摊到每一行项目中，使每个项目都能获得公平的比例

下面的VBA代码采用第四个选项。可以使用公式手动执行此操作，但这将非常耗时；相反，下面的VBA代码只需要2秒钟。

Sub ApportionValueAcrossCells()
 Dim apportionValue As Double
 Dim keepAsFormula As Long
 Dim total As Double
 Dim c As Range
 Dim formulaString As String
 '获取现有的总数
 total = Application.WorksheetFunction.Sum(Selection)
 '核查所选单元格总数不等于0
 If total = 0 Then
   MsgBox Prompt:="所有单元格的总和不应为0", _
     Title:="Apportion value"
   Exit Sub
 End If
 '获取去分配的值
 apportionValue = Application.InputBox(Prompt:="要分配的值:", _
   Title:="分配值", Type:=1)
 '用户单击取消
 If apportionValue = False Then Exit Sub
 '获取布尔值以保留公式或对结果进行硬编码
 keepAsFormula = MsgBox("保留公式?", vbYesNo)
 '遍历所选区域每一单元格
 For Each c In Selection
   If IsNumeric(c.Value) Then
     '计算单元格的结果
     formulaString = c.Formula & "+(" & apportionValue & _
     "/" & total & "*" & c.Value & ")"
     If Left(formulaString, 1) <> "=" Then _
       formulaString = "=" & formulaString
     '输入公式到单元格
     c.Formula = formulaString
     '重新计算当前单元格
     ActiveCell.Calculate
     If keepAsFormula = vbNo Then
       c.Value = c.Value
     End If
   End If
 Next c
End Sub

首先，选择包含值的数据区域，如下图1所示。