VBA formula not calculating and dynamic references-CodePudding

I have a spreadsheet with 1,000 rows. Each row has six column categories with different weights (30%, 20%, 20%, 10%, 15%, 5%) that are scored either 1,2,3,4,5 or N/A and then a rating which compiles the overall score, so the first row is 5*.3, 2*.2, 1*.1, 1*.15, 5*.05 for a total of 2.4. I want to reassign the values if a column has N/A so if the first column which is worth 30% has an N/A, I want the new remaining five values to be worth 26%, 26%, 16%, 21%, 11% (yes I would like to add 6% to each and not redistribute the 30% based on current weights). How do I do this with VBA code? If two columns have N/A then I will distribute the total weight of those two columns to the other four and so on. I've gotten the suggestion here of not doing the 60 if-thens for all of the combos and so I tried to handle it by adding the NA percentages, counting the NAs, then adding the new weights to the old weights. I know the last formula itself needs to be slightly edited, but I would appreciate help with why CatPercentage1 is coming up 0 even though AD2 is N/A and as importantly how to make this dynamic to account for all the rows. Thanks!

Option Explicit
Function NewValue()
End Function
Sub CalculateNewValue()

Dim CatPercentage1 As Single
Dim CatPercentage2 As Single
Dim CatPercentage3 As Single
Dim CatPercentage4 As Single
Dim CatPercentage5 As Single
Dim CatPercentage6 As Single
Dim CatValue1 As Single
Dim CatValue2 As Single
Dim CatValue3 As Single
Dim CatValue4 As Single
Dim CatValue5 As Single
Dim CatValue6 As Single
Dim TotalPercentageNA As Single
Dim NumberNA As Integer
Dim RemainingCat As Integer
Dim AddValue As Single
Dim NewValue As Single
Dim lRow As Long

'lRow = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
'Range("AJ2").AutoFill Range("AJ2:AJ" & lRow)

NumberNA = 0
If Range("AD2") = "N/A" Then
CatPercentage1 = 0.3 And NumberNA = NumberNA   1 And CatValue1 = 0
If Range("AE2") = "N/A" Then
CatPercentage1 = 0.2 And NumberNA = NumberNA   1 And CatValue2 = 0
If Range("AF2") = "N/A" Then
CatPercentage1 = 0.2 And NumberNA = NumberNA   1 And CatValue3 = 0
If Range("AG2") = "N/A" Then
CatPercentage1 = 0.1 And NumberNA = NumberNA   1 And CatValue4 = 0
If Range("AH2") = "N/A" Then
CatPercentage1 = 0.15 And NumberNA = NumberNA   1 And CatValue5 = 0
If Range("AI2") = "N/A" Then
CatPercentage1 = 0.05 And NumberNA = NumberNA   1 And CatValue6 = 0
End If
End If
End If
End If
End If
End If

TotalPercentageNA = (CatPercentage1   CatPercentage2   CatPercentage3   CatPercentage4   CatPercentage5   CatPercentage6)
RemainingCat = 6 - NumberNA
AddValue = TotalPercentageNA / RemainingCat

'MsgBox CatPercentage1
'MsgBox TotalPercentageNA
'MsgBox RemainingCat
'MsgBox NumberNA
'MsgBox AddValue


Range("AJ2").Value = CatValue1 * Range("AE2").Value * (0.3   AddValue)   Range("AE2").Value * (0.2   AddValue)   Range("AF2").Value * (0.2   AddValue)   Range("AG2").Value * (0.1   AddValue)   Range("AH2").Value * (0.15   AddValue)   Range("AI2").Value * (0.05   AddValue)

End Sub

CodePudding user response：

I hope this helps to explain and also match with your desired outcome:

SUMIF to calculate the percentages of columns with N/A
COUNTIF to count columns with a value <> N/A
add the share to all 6 “base” percentages (total is more than 100% but does not matter as N/A columns will be multiplied with 0)
multiple with the respective ”NEW” percentages related factor replacing N/A with 0; adding all together

Edit: the 8% share in the second line is just due to the display format without decimal and can be change e.g. to 2 decimal

CodePudding user response：

This should be close to what you describe I think:

Function Weighted(rngVals As Range, rngWeights As Range)
    
    Dim arrVals, arrWeights, numNA As Long, i As Long, arrNA() As Boolean
    Dim c As Long, ub As Long, inc As Double, rv As Double
    
    arrWeights = rngWeights.Value 'read weights and values to arrays
    arrVals = rngVals.Value
    
    ub = UBound(arrVals, 2) 'how many values
    ReDim arrNA(1 To ub)    'for tracking N/A values
    For i = 1 To ub         'count of "N/A"
        arrNA(i) = arrVals(1, i) = "N/A"
        numNA = numNA   IIf(arrNA(i), 1, 0) 'increment count?
    Next i
    
    If numNA > 0 And numNA < ub Then 'any need to adjust weightings?
        For i = 1 To ub
            If arrNA(i) Then 'no score: distribute the weighting for this value
                inc = (arrWeights(1, i) / (ub - numNA)) 'fraction to distribute
                For c = 1 To ub
                    'only increment used weights
                    If Not arrNA(c) Then arrWeights(1, c) = arrWeights(1, c)   inc
                Next c
            End If
        Next i
    End If
    'finally calculate the weighted sum
    For i = 1 To ub
        If Not arrNA(i) Then rv = rv   (arrVals(1, i) * arrWeights(1, i))
    Next i
    
    Weighted = rv
End Function