Re calculation of weights

erdem_ustun

New Member
Joined
Jun 19, 2018
Messages
12
Hi,

I have excel files.

There are different sections in this file.

There are different features under each section.
Unequal weights are available for these features.
The sum of each section is 10.
However, if there are no features under a section, the weight of the non-features needs to be proportionally distributed to other features existing under the same section.
How can I do this with VBA.
First I set all the features and weights by default. Later, if the cell were written "No" in the column next to the no features, I thought it would be necessary to re-distribute the weight in this section.

But I could not .

As sample data

NbrSection 1Default weightsStatusReweighted
1.1Feature 133,75
1.2Feature 256,25
1.3Feature 32No
Section 2
2.1Feature 155
2.2Feature 255
Section 3
3.1Feature 12No
3.2Feature 2210
3.3Feature 32No
3.4Feature 44No
...

..................

<tbody>
</tbody>


I would like your help in this regard.
 
If you need a reference to the original weightings then you're back to the first solution I think.

WBD
 
Upvote 0

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
If you need a reference to the original weightings then you're back to the first solution I think.

WBD

I agree with your thoughts.

I think it would be more effective to keep the original references in an array and process them.

Like as

Code:
Dim  Default_weight(9, 1) As Variant
Default_weight(1, 0) = 1.1
Default_weight(1, 1) = 0.4
Default_weight(2, 0) = 1.2
Default_weight(2, 1) = 0.5
Default_weight(3, 0) = 1.3
Default_weight(3, 1) = 0.1
Default_weight(4, 0) = 2.1
Default_weight(4, 1) = 0.5
Default_weight(5, 0) = 2.2
Default_weight(5, 1) = 0.5
Default_weight(6, 0) = 3.1
Default_weight(6, 1) = 0.2
Default_weight(7, 0) = 3.2
Default_weight(7, 1) = 0.2
Default_weight(8, 0) = 3.3
Default_weight(8, 1) = 0.2
Default_weight(9, 0) = 3.4
Default_weight(9, 1) = 0.4
 
Last edited:
Upvote 0
hi wideboydixon,

Thank you very much for the idea you have and for the code you have written.
I changed the code you wrote a bit.For the last I want to do.

But since I do not want to make mistakes, I have a request from you for the code to work effectively and quickly.


If you have the chance to check it, I'm very happy.
Code:
Sub ReweightFeatures_V3()
Dim Default_weight(11, 1) As Variant
Dim i As Integer
Dim lastRow As Long
Dim thisRow As Long
Dim firstRow As Long
Dim weightTotal As Double


Default_weight(1, 0) = "1.1"
Default_weight(1, 1) = 3
Default_weight(2, 0) = "1.2"
Default_weight(2, 1) = 3
Default_weight(3, 0) = "1.3"
Default_weight(3, 1) = 4
Default_weight(6, 0) = "2.1"
Default_weight(6, 1) = 5
Default_weight(7, 0) = "2.2"
Default_weight(7, 1) = 5
Default_weight(8, 0) = "3.1"
Default_weight(8, 1) = 3
Default_weight(9, 0) = "3.2"
Default_weight(9, 1) = 3
Default_weight(10, 0) = "3.3"
Default_weight(10, 1) = 2
Default_weight(11, 0) = "3.4"
Default_weight(11, 1) = 2


lastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
firstRow = 0
weightTotal = 0
For thisRow = 3 To lastRow
    If Cells(thisRow, 1) = "" Then
        ProcessSection firstRow, thisRow - 1, weightTotal
        firstRow = 0
        weightTotal = 0
    Else
        If firstRow = 0 Then firstRow = thisRow

[/COLOR][COLOR=#49644E]If Cells(thisRow, "C").Value <> "No" Then thisRow = thisRow  
[/COLOR][COLOR=#49644E]
       
        For i = 1 To UBound(Default_weight)
        
            If Cells(thisRow, 1) = Default_weight(i, 0) And Cells(thisRow, "C").Value <> "No" Then
                
                Cells(thisRow, "C").Value = Default_weight(i, 1)
                weightTotal = weightTotal + Cells(thisRow, "C").Value
                Exit For
            End If
        Next i
        
        
    End If
Next thisRow


End Sub[/COLOR][COLOR=#49644E]



Code:
Private Sub ProcessSection(firstRow As Long, lastRow As Long, weightTotal As Double)


Dim thisRow As Long


For thisRow = firstRow To lastRow
    If Cells(thisRow, "C").Value <> "No" Then
        Cells(thisRow, "C").Value = Cells(thisRow, "C").Value / weightTotal * 10
    End If
Next thisRow


End Sub

[/COLOR]


Best wishes
 
Last edited:
Upvote 0
Despite its normal appearance in the editor, it appears to be sent in pieces.
Sorry.

hi wideboydixon,


Thank you very much for the idea you have and for the code you have written.
I changed the code you wrote a bit.For the last I want to do.


But since I do not want to make mistakes, I have a request from you for the code to work effectively and quickly.




If you have the chance to check it, I'm very happy.
Code:
Sub ReweightFeatures_V3()
Dim Default_weight(11, 1) As Variant
Dim i As Integer
Dim lastRow As Long
Dim thisRow As Long
Dim firstRow As Long
Dim weightTotal As Double




Default_weight(1, 0) = "1.1"
Default_weight(1, 1) = 3
Default_weight(2, 0) = "1.2"
Default_weight(2, 1) = 3
Default_weight(3, 0) = "1.3"
Default_weight(3, 1) = 4
Default_weight(6, 0) = "2.1"
Default_weight(6, 1) = 5
Default_weight(7, 0) = "2.2"
Default_weight(7, 1) = 5
Default_weight(8, 0) = "3.1"
Default_weight(8, 1) = 3
Default_weight(9, 0) = "3.2"
Default_weight(9, 1) = 3
Default_weight(10, 0) = "3.3"
Default_weight(10, 1) = 2
Default_weight(11, 0) = "3.4"
Default_weight(11, 1) = 2


lastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
firstRow = 0
weightTotal = 0
For thisRow = 3 To lastRow
    If Cells(thisRow, 1) = "" Then
        ProcessSection firstRow, thisRow - 1, weightTotal
        firstRow = 0
        weightTotal = 0
    Else
        If firstRow = 0 Then firstRow = thisRow


If Cells(thisRow, "C").Value <> "No" Then thisRow = thisRow


      
        For i = 1 To UBound(Default_weight)
        
            If Cells(thisRow, 1) = Default_weight(i, 0) And Cells(thisRow, "C").Value <> "No" Then
                
                Cells(thisRow, "C").Value = Default_weight(i, 1)
                weightTotal = weightTotal + Cells(thisRow, "C").Value
                Exit For
            End If
        Next i
        
        
    End If
Next thisRow
End Sub




Code:
Private Sub ProcessSection(firstRow As Long, lastRow As Long, weightTotal As Double)




Dim thisRow As Long




For thisRow = firstRow To lastRow
    If Cells(thisRow, "C").Value <> "No" Then
        Cells(thisRow, "C").Value = Cells(thisRow, "C").Value / weightTotal * 10
    End If
Next thisRow




End Sub


Best wishes
 
Last edited:
Upvote 0

Book1
ABC
1NbrSectionsWeights
2Section 1
31.1Feature 1
41.2Feature 2
51.3Feature 3No
6Section 2
72.1Feature 1
82.2Feature 2
9Section 3
103.1Feature 1No
113.2Feature 2
123.3Feature 3No
133.4Feature 4No
Sheet1


Code:
Dim defaultWeights As Variant
Public Sub ReweightFeatures()

Dim lastRow As Long
Dim thisRow As Long
Dim firstRow As Long
Dim weightTotal As Double

defaultWeights = Split("3,5,2,,5,5,,2,2,2,4", ",")

lastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
firstRow = 0
weightTotal = 0
For thisRow = 3 To lastRow
    If Cells(thisRow, 1) = "" Then
        ProcessSection firstRow, thisRow - 1, weightTotal
        firstRow = 0
        weightTotal = 0
    Else
        If firstRow = 0 Then firstRow = thisRow
        If Cells(thisRow, "C").Value <> "No" Then weightTotal = weightTotal + CDbl(defaultWeights(thisRow - 3))
    End If
Next thisRow

End Sub
Private Sub ProcessSection(firstRow As Long, lastRow As Long, weightTotal As Double)

Dim thisRow As Long

For thisRow = firstRow To lastRow
    If Cells(thisRow, "C").Value <> "No" Then
        Cells(thisRow, "C").Value = CDbl(defaultWeights(thisRow - 3)) / weightTotal * 10
    End If
Next thisRow

End Sub


Book1
ABC
1NbrSectionsWeights
2Section 1
31.1Feature 13.75
41.2Feature 26.25
51.3Feature 3No
6Section 2
72.1Feature 15
82.2Feature 25
9Section 3
103.1Feature 1No
113.2Feature 210
123.3Feature 3No
133.4Feature 4No
Sheet1


WBD
 
Upvote 0
Solution

Forum statistics

Threads
1,213,550
Messages
6,114,265
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top