Взвешенная сумма в VBA

Question

Я пытаюсь взять взвешенную сумму около 6 500 значений с разным весом в Excel с помощью VBA. Вот упрощенный пример того, что я ищу:

Я уже Столбцы А и В, и я ищу для кода VBA, который можно распечатать, что видно выше, в колонке C под «Weighted Сумма». Например, первый «3», напечатанный в «взвешенной сумме», рассчитывается следующим образом: (5 * 0,5) + (1 * 0,5) = 3. Я хотел бы сделать эту динамику, чтобы я мог изменить вес (который в настоящее время показаны на 50% выше).

Answer 1

Надеюсь, вы найдете это полезным. Первый урок: не все в Excel требует VBA, я создал файл Excel с двумя вкладками:

1.) Пример - Нет VBA | Показывает, как это сделать без VBA, один из многих подходов

2.) Пример - VBA | Показывает, как сделать это с помощью VBA, один из многих подходов

Помните, что Alt + F11 открывает редактор для просмотра исходного кода перед запуском любой макрос

Рабочий пример можно скачать здесь:

https://dl.dropboxusercontent.com/u/15166388/StackOverflow/Weighted-Sum-in-VBA/weighted-sum.xlsm

Вот код:

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 

Answer 2

Добавление другого фрагмента кода для ответа на следующий вопрос smathu3. Пожалуйста, прочитайте комментарии к коду и при необходимости адаптируйте их.

* Как я могу сделать это так, чтобы веса были динамическими? Здесь у вас есть веса как часть кода: ActiveCell.FormulaR1C1 = "= (RC [-2] * 0.5) + (RC [-1] 0.5)". Если весы могут быть показаны как ячейки, которые были бы большими. - smathu3

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