Product sum for min, max and the colored cells in VBA

bilbon

Board Regular
Joined
Dec 19, 2011
Messages
83
Hi
Someone who can help me figure out the product sum for min, max and the colored cells in A2:C9.
The coloured cells have a colour index of 15 and 40.
Preferably VBA code

/Bilbon




<colgroup><col span="3"><col><col><col></colgroup><tbody></tbody>

ABCMinMaxColored cells
0,910,971,210,367,850,98
1,180,891,00
1,231,000,87
0,920,911,21
0,811,241,67
0,871,131,33
1,020,871,12
0,921,111,50

<colgroup><col span="3"><col><col><col></colgroup><tbody>
</tbody>
 

Some videos you may like

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Can you explain your example?
 

bilbon

Board Regular
Joined
Dec 19, 2011
Messages
83
Hi DanteAmor


I calculate the numbers every day and the coloured cells are different every day.
It is the cell that has a fill color.

Min is the smallest numbers on each line * each other
0.91 * 0.89 * 0.87 * 0.91 * 0,81 * 0.87 * 0.87 * 0,92


Max is the largest numbers on each line * each other.
1.21 * 1.18 * 1.23 * 1.21 * 1,67 * 1.33 * 1.12 * 1.50


Colored cells are the colored cells on each row * each other.
0,97 * 0.89 * 0.87 * 0,92 * 1.24 * 1.13 * 1.12 * 0,92

/Bilbon
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Try this, Your data should start in cell A1

Code:
Sub Product_Sum()


    u = Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To u
        wMin = WorksheetFunction.Min(Range("A" & i).Resize(1, 3))
        wMax = WorksheetFunction.Max(Range("A" & i).Resize(1, 3))
        If pMin = 0 Then pMin = wMin Else pMin = pMin * wMin
        If pMax = 0 Then pMax = wMax Else pMax = pMax * wMax
    
        For j = 1 To 3
            If Cells(i, j).Interior.ColorIndex = 15 Or Cells(i, j).Interior.ColorIndex = 40 Then
                If pCol = 0 Then pCol = Cells(i, j).Value Else pCol = pCol * Cells(i, j).Value
            End If
        Next
    Next
    
    Range("D2").Value = pMin
    Range("E2").Value = pMax
    Range("F2").Value = pCol
    
End Sub
 

bilbon

Board Regular
Joined
Dec 19, 2011
Messages
83

ADVERTISEMENT

Hi DanteAmor


The code works perfectly. Will save a lot of time for me.
I am very grateful for your help.Thank you very much.


/Bilbon
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

bilbon

Board Regular
Joined
Dec 19, 2011
Messages
83

ADVERTISEMENT

Hi


Would it be possible to make DanteAmors code to 3 UDF?
1 for MIN and 1 for MAX and 1 for COLORED CELLS.
Anyone have that knowledge?
I have seen that they would be even more helpful.


/Bilbon
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Go the 3 udf.

You put the udf and the range, e.g .:

=udf_Min(A1:C8)
=udf_Max(A1:C8)
=udf_colored_cells(A1:C8)

Code:
Function [B]udf_Min[/B](rng As Range)


    u = rng.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To u
        wMin = WorksheetFunction.Min(rng.Cells(i, 1).Resize(1, 3))
        If pMin = 0 Then pMin = wMin Else pMin = pMin * wMin
    Next
    udf_Min = pMin
    
End Function


Function [B]udf_Max[/B](rng As Range)


    u = rng.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To u
        wMax = WorksheetFunction.Max(rng.Cells(i, 1).Resize(1, 3))
        If pMax = 0 Then pMax = wMax Else pMax = pMax * wMax
    Next
    udf_Max = pMax
    
End Function


Function [B]udf_colored_cells[/B](rng As Range)


    u = rng.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To u
    
        For j = 1 To rng.Cells(1, Columns.Count).End(xlToLeft).Column
            If rng.Cells(i, j).Interior.ColorIndex = 15 Or rng.Cells(i, j).Interior.ColorIndex = 40 Then
                If pCol = 0 Then pCol = rng.Cells(i, j).Value Else pCol = pCol * rng.Cells(i, j).Value
            End If
        Next
    Next
    udf_colored_cells = pCol
    
End Function

Additionally, put the following code in the events of your sheet; As the color udf is not activated if you put the color manually, then to update the result of the color udf, you will have to select any cell.

Code:
Private Sub [B]Worksheet_SelectionChange[/B](ByVal Target As Range)
    Calculate
End Sub
 

bilbon

Board Regular
Joined
Dec 19, 2011
Messages
83
Hi DanteAmor


Thank you for your reply.
Must the data I should figure out be in A1: C8?
Works well with the data in A1: C8 but tried to move the data to A11: C19 then I get #VALUE ! Error.


/Bilbon
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Try:

Code:
Function udf_Min(rng As Range)


[COLOR=#0000ff]    u = rng.Rows.Count[/COLOR]
    For i = 1 To u
        wMin = WorksheetFunction.Min(rng.Cells(i, 1).Resize(1, 3))
        If pMin = 0 Then pMin = wMin Else pMin = pMin * wMin
    Next
    udf_Min = pMin
    
End Function


Function udf_Max(rng As Range)


[COLOR=#0000ff]    u = rng.Rows.Count[/COLOR]
    For i = 1 To u
        wMax = WorksheetFunction.Max(rng.Cells(i, 1).Resize(1, 3))
        If pMax = 0 Then pMax = wMax Else pMax = pMax * wMax
    Next
    udf_Max = pMax
    
End Function


Function udf_colored_cells(rng As Range)
[COLOR=#0000ff]    u = rng.Rows.Count[/COLOR]
    For i = 1 To u
    
        For j = 1 To rng.Cells(1, Columns.Count).End(xlToLeft).Column
            If rng.Cells(i, j).Interior.ColorIndex = 15 Or rng.Cells(i, j).Interior.ColorIndex = 40 Then
                If pCol = 0 Then pCol = rng.Cells(i, j).Value Else pCol = pCol * rng.Cells(i, j).Value
            End If
        Next
    Next
    udf_colored_cells = pCol
    
End Function
 

Watch MrExcel Video

Forum statistics

Threads
1,108,490
Messages
5,523,249
Members
409,506
Latest member
reneekeane

This Week's Hot Topics

Top