Link to home
Start Free TrialLog in
Avatar of DAVID131
DAVID131

asked on

Ammend a Private routine

The attached code was supplied by EE and works beautifully but due to changes in processes I need to control the codes application via a button instead of it automatically running when cell J1 changes.
How do I do this?
Thanks
D

Private Sub Worksheet_Change(ByVal target As Range)
Dim Commissions As Range
Dim Deciles As Range
Dim row As Range
Dim rng As Range
Dim spread As Long
Dim total As Long
   
    If target.Address = "$J$1" Then
        ' If cell J1 has changed, calculate the number of customers
        'The original code was for deciles, this was subsequently changed to quintiles
        Set Commissions = ActiveSheet.Range("QCommissions")
        Set Deciles = ActiveSheet.Range("QDeciles")
        For Each row In Commissions.Rows
            total = 0
            For Each rng In Deciles.Rows
                If rng.Cells(1, 1) >= row.Cells(1, 1) _
                    And rng.Cells(1, 2) <= row.Cells(1, 2) Then
                        ' The entire decile falls within the range
                        total = total + target.Value / 5
                ElseIf rng.Cells(1, 1) < row.Cells(1, 2) _
                    And rng.Cells(1, 2) > row.Cells(1, 2) Then
                        ' The beginning of the decile overlaps the range
                        spread = (rng.Cells(1, 2) - rng.Cells(1, 1) + 1) / (target.Value / 5)
                        total = total + (row.Cells(1, 2) - rng.Cells(1, 1)) / spread
                ElseIf rng.Cells(1, 1) < row.Cells(1, 1) _
                    And rng.Cells(1, 2) > row.Cells(1, 1) _
                    And rng.Cells(1, 2) <= row.Cells(1, 2) Then
                        ' The end of the decile overlaps the range
                        spread = (rng.Cells(1, 2) - rng.Cells(1, 1) + 1) / (target.Value / 5)
                        total = total + (rng.Cells(1, 2) - row.Cells(1, 1) + 2) / spread
                End If
            Next rng
            row.Cells(1, 4) = total
        Next row
    End If
End Sub
Avatar of Barry Cunney
Barry Cunney
Flag of Ireland image

What version of Excel are you using?
ASKER CERTIFIED SOLUTION
Avatar of Rory Archibald
Rory Archibald
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Create a button and assign a new macro to it.

This should leads you to a new sub-routine
something like :

Sub Button1_Click()

End Sub

Open in new window


Copy paste the following code in this sub routine

Dim Commissions As Range
Dim Deciles As Range
Dim row As Range
Dim rng As Range
Dim spread As Long
Dim total As Long
    
        'The original code was for deciles, this was subsequently changed to quintiles
        Set Commissions = ActiveSheet.Range("QCommissions")
        Set Deciles = ActiveSheet.Range("QDeciles")
        For Each row In Commissions.Rows
            total = 0
            For Each rng In Deciles.Rows
                If rng.Cells(1, 1) >= row.Cells(1, 1) _
                    And rng.Cells(1, 2) <= row.Cells(1, 2) Then
                        ' The entire decile falls within the range
                        total = total + target.Value / 5
                ElseIf rng.Cells(1, 1) < row.Cells(1, 2) _
                    And rng.Cells(1, 2) > row.Cells(1, 2) Then
                        ' The beginning of the decile overlaps the range
                        spread = (rng.Cells(1, 2) - rng.Cells(1, 1) + 1) / (target.Value / 5)
                        total = total + (row.Cells(1, 2) - rng.Cells(1, 1)) / spread
                ElseIf rng.Cells(1, 1) < row.Cells(1, 1) _
                    And rng.Cells(1, 2) > row.Cells(1, 1) _
                    And rng.Cells(1, 2) <= row.Cells(1, 2) Then
                        ' The end of the decile overlaps the range
                        spread = (rng.Cells(1, 2) - rng.Cells(1, 1) + 1) / (target.Value / 5)
                        total = total + (rng.Cells(1, 2) - row.Cells(1, 1) + 2) / spread
                End If
            Next rng
            row.Cells(1, 4) = total
        Next row

Open in new window



Basically, I simply removed the first and last line (which is the old sub-routine name)
and the test on the modified cell $J$1

I havent tested it because i dont have the corresponding excel file
You need to replace the references to target.value as well ;)
Avatar of DAVID131
DAVID131

ASKER

Thank you very much, you got this spot on!