用于为表的最后一列应用不同百分比的 VBA 代码

Question

这是我目前所拥有的：

Sub test()
    Dim r As Range, n As Integer, i As Integer
    On Error Resume Next
    Set r = Application.InputBox("Select the range", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    n = Application.InputBox("How many departments?")
    c = ActiveCell.Column
    r.Copy
    For i = 1 To n
        Cells(ActiveCell.Row, c + (i - 1) * (r.Columns.Count + 1)).Activate
        ActiveCell.PasteSpecial Paste:=xlPasteValues
    Next i
    Application.CutCopyMode = False
End Sub

到目前为止这个宏，

1. 提示用户选择一个范围。该范围将是另一个工作表中的表格。
2. 然后它会再次提示用户询问有多少部门，并根据该数字，它将所选范围复制到新工作表中特定次数。
3. 下一步是 - 根据部门类型 - 用户需要输入一个百分比并将该百分比应用于所选范围的最后一列，即销售收入。

例如，如果用户输入有 5 个部门，它将在新工作表中复制表格 5 次。然后它应该再次提示用户询问 5 个部门中每个部门的百分比份额是多少，并将最后一列（销售收入）乘以它们各自的百分比。为了更好地说明我的观点，这里有一个示例工作簿：

Dummy Data on GoogleDrive

关于如何做到这一点的任何建议？

Answer 1

这种方法怎么样 - 当您复制值时，将最后一列替换为链接到原始范围的公式，并在复制列下方的百分比值。允许用户直接在电子表格中修改这些百分比。比如：

Sub test()
    Dim r As Range, n As Integer, i As Integer, c As Integer
    Dim vals As Variant
    Dim cRange As Range
    Dim pCell As Range 'to hold percentage
    Dim numRows As Integer, numCols As Integer
    Dim fcol As String
    On Error Resume Next
    Set r = Application.InputBox("Select the range", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub

    numCols = r.Columns.Count
    numRows = r.Rows.Count
    vals = r.Value

    fcol = r.Columns(numCols).Address
    fcol = "'" & r.Parent.Name & "'!" & fcol

    n = Application.InputBox("How many departments?")
    c = ActiveCell.Column
    Set cRange = Range(ActiveCell, ActiveCell.Offset(numRows - 1, numCols - 1))
    For i = 1 To n
        cRange.Value = vals
        Set pCell = cRange.Cells(1, 1).Offset(numRows, numCols - 1)
        pCell.Value = 100 '=100%
        cRange.Columns(numCols).FormulaArray = "=" & fcol & " * " & "0.01 * " & pCell.Address
        pCell.Offset(1).Value = "Department " & i & "'s %"
        Set cRange = cRange.Offset(0, numCols + 1)
    Next i

End Sub

在这段代码中，我展示了一种使用范围对象值属性和变量数组传输数据的标准方法。在VBA中很少需要选择、复制和粘贴