VBA中的加权和

我尝试使用VBA在Excel中获取大约6500个不同权重值的加权和。以下是我正在寻找的一个简化示例：

---

我已经有了A列和B列，我正在寻找VBA代码，它可以打印出上面C列“加权和”下的内容。例如，“加权和”中打印的第一个“3”是这样计算的：（5*0.5）+（1*0.5）=3。我想将其动态化，以便更改权重（目前显示为50%以上）。

我希望这对您有所帮助。第一课：并非Excel中的所有内容都需要VBA，我已创建了一个包含两个选项卡的Excel文件：

1.）示例-无VBA |显示了如何在没有VBA的情况下实现这一点，VBA是许多方法之一

2.）示例-VBA |展示了如何使用VBA实现这一点，VBA是许多方法之一

请记住，在运行任何宏之前，Alt+F11会打开编辑器以查看源代码

工作示例可从此处下载：

代码如下：

Public Sub WeightedSum()
'---------------------------------------------------------------------------------------
' Method : WeightedSum
' Author : vicsar
' Date   : June/13/2016
' Purpose: Teach Basic VBA
' Ref.: https://stackoverflow.com/questions/37799607/weighted-sum-in-vba
' Working example can be downloaded from here:
' https://dl.dropboxusercontent.com/u/15166388/StackOverflow/Weighted-Sum-in-VBA/weighted-sum.xlsm
'---------------------------------------------------------------------------------------

    On Error GoTo MistHandler

    Dim lngLastRowInExcel As Long
    Dim lngLastRowContainingData As Long
    Dim lngCounter As Long


    ' Basic dummy proofing
    ' Check for headers
    If Range("A1").Value = vbNullString Then
        MsgBox "Unable to find headers. Please review the file and try again", vbCritical, "Error"
        Exit Sub
    End If

    ' Check for empty columns
    If Range("A2").Value = vbNullString Then
        MsgBox "Unable to find values in cell A2. Please review the file and try again", vbCritical, "Error"
        Exit Sub
    End If


    ' Since the following steps require many screens refreshes using this will make it run fast  You won't be able
    ' to see what the macro is doing, but it will run faster.
    Application.ScreenUpdating = False

    ' Defining the last row containign data
    ' Using this approach to make the macro backwards compatile with other versions of Excel
    ActiveCell.SpecialCells(xlLastCell).Select
    Selection.End(xlDown).Select
    lngLastRowInExcel = ActiveCell.Row
    Range("A" & lngLastRowInExcel).Select
    Selection.End(xlUp).Select
    lngLastRowContainingData = ActiveCell.Row

    Range("A2").Select

    ' Move selection two columns to the right
    ActiveCell.Offset(0, 2).Select

    ' This loop repeats the formula on every single row adjacent to a value
    For lngCounter = 1 To lngLastRowContainingData - 1
        ActiveCell.FormulaR1C1 = "=(RC[-2]*0.5)+(RC[-1]*0.5)"
        ActiveCell.Offset(1, 0).Select
    Next

    ' Removing formulas, replacing with values (optional)
    Columns("A:C").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

    ' Exit Excel's copy mode
    Application.CutCopyMode = False

    ' Go to A1, scroll to it
    Range("A1").Select
    Application.Goto ActiveCell, True

    ' Autofit columns
    Columns.EntireColumn.AutoFit

    ' Allowing screen updates again
    Application.ScreenUpdating = True


    On Error GoTo 0
    Exit Sub

    ' Error handler
MistHandler:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure WeightedSum of basMain", vbExclamation, " vicsar says"

End Sub

---

添加另一个代码片段以回答smathu3提出的后续问题。请阅读代码注释，并根据需要进行调整

---

*如何使权重具有动态性？这里您将权重作为代码的一部分：ActiveCell.FormulaR1C1=“=（RC[-2]*0.5）+（RC[-1]0.5）”。如果权重可以显示为单元格，那就太好了smathu3

---

在这里，你通常被要求在发帖前至少尝试解决你的问题，并在问题中包含你当前的代码（即使它不太有效）sumproduct怎么样？甚至不是sumproduct，只是一个奇怪的

A2*$a$1+B2*$B$1

。你真的需要在Excel中学习非常基本的公式。@vacip

freaking

我觉得我回到了中学这让我笑了。这是一个产品！基本的，但仍然是和积

=sumproduct（$A$1:$B$1，A2:B2）

如果你开始得到两列以上的内容，我认为sumproduct的输入时间会短一些。很多代码类似于

目的：教授基本VBA

；），但请不要误会我，我对你的教学方法很满意。非常感谢。感谢你们两位随时提供的帮助。我如何使重量保持动态？这里您将权重作为代码的一部分：ActiveCell.FormulaR1C1=“=（RC[-2]*0.5）+（RC[-1]*0.5）”。如果权重可以显示为单元格，那就太好了。我已经更新了代码，下载文件查看更改。我在添加第二个答案，如果它对您有效，那么我将感谢您将其标记为已接受的答案。

Public Sub WeightedSumDynamicWeights()
'---------------------------------------------------------------------------------------
' Method : WeightedSumDynamicWeights
' Author : vicsar
' Date   : June/13/2016
' Purpose: Teach Basic VBA
' Ref.: https://stackoverflow.com/questions/37799607/weighted-sum-in-vba
' Working example can be downloaded from here:
' https://dl.dropboxusercontent.com/u/15166388/StackOverflow/Weighted-Sum-in-VBA/weighted-sum.xlsm
'---------------------------------------------------------------------------------------

    On Error GoTo MistHandler

    Dim lngLastRowInExcel As Long
    Dim lngLastRowContainingData As Long
    Dim lngCounter As Long

    ' Basic dummy proofing
    ' Check for headers
    If Range("A1").Value = vbNullString Then
        MsgBox "Unable to find headers. Please review the file and try again", vbCritical, "Error"
        Exit Sub
    End If

    ' Check for empty columns
    If Range("A2").Value = vbNullString Then
        MsgBox "Unable to find values in cell A2. Please review the file and try again", vbCritical, "Error"
        Exit Sub
    End If


    ' Since the following steps require many screens refreshes using this will make it run fast  You won't be able
    ' to see what the macro is doing, but it will run faster.
    Application.ScreenUpdating = False

    ' Defining the last row containign data
    ' Using this approach to make the macro backwards compatile with other versions of Excel
    ActiveCell.SpecialCells(xlLastCell).Select
    Selection.End(xlDown).Select
    lngLastRowInExcel = ActiveCell.Row
    Range("A" & lngLastRowInExcel).Select
    Selection.End(xlUp).Select
    lngLastRowContainingData = ActiveCell.Row

    Range("A2").Select

    ' Move selection two columns to the right
    ActiveCell.Offset(0, 2).Select

    ' This loop repeats the formula on every single row adjacent to a value
    For lngCounter = 1 To lngLastRowContainingData - 1
        ' Here is the formula, change all instances of Range("F2") to the cell in which you want to store the weight
        ActiveCell.Value = (ActiveCell.Offset(0, -2).Value * Range("F2")) + (ActiveCell.Offset(0, -1).Value * Range("F2"))
        ActiveCell.Offset(1, 0).Select
    Next

    ' Go to A1, scroll to it
    Range("A1").Select
    Application.Goto ActiveCell, True

    ' Autofit columns
    Columns.EntireColumn.AutoFit

    ' Allowing screen updates again
    Application.ScreenUpdating = True


    On Error GoTo 0
    Exit Sub

    ' Error handler
MistHandler:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure WeightedSumDynamicWeights of basMain", vbExclamation, " vicsar says"

End Sub