• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 365
  • Last Modified:

How to run through array and format cells with VBA

Hello.  I have a worksheet with Names down the left side, a blank row, and then number values.  I am really stumped as how to step through.  I have attached a file as an example.

What I need is to add the values from each column if a person is listed twice, then if the number is over 100, set the interior color of the cell to yellow.  I know this could be done with conditional formatting but the other parts of the workbook is so large and slow I wanted to set the formatting statically with VBA.

For example, in my worksheet Alex is listed twice in column D.  The sum for him in column D is > 100.  So set the interior color for those cells to yellow.
VBAExample.xlsx
0
drhamel69
Asked:
drhamel69
  • 7
  • 6
  • 3
  • +1
1 Solution
 
NorieData ProcessorCommented:
This worked for me.

Select C3:F11, goto conditional formatting, select the formula option, enter this formula,

=SUMIF($A$3:$A$11,$A3,C$3:C$11)

and format as required.
0
 
drhamel69Author Commented:
If you read my post you would be aware that I CAN NOT use conditional formatting.
0
 
NorieData ProcessorCommented:
Oops, my bad.

What do you mean by setting the format statically?
0
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
NorieData ProcessorCommented:
Try this.
Dim cl As Range
Dim rng1 As Range
Dim rng2 As Range
Dim res As Range

Dim tot
    Set rng1 = Range("A3:A6")
    Set rng2 = Range("A8:A10")

    For I = 2 To 5
        For Each cl In rng1
            res = Application.Match(cl.Value, rng2, 0)

            If Not IsError(res) Then
                tot = cl.Offset(, I) + rng2.Cells(res, 1).Offset(, I)

                If tot > 100 Then
                    cl.Offset(, I).Interior.ColorIndex = 6
                    rng2.Cells(res, 1).Offset(, I).Interior.ColorIndex = 6
                End If

            End If
        Next cl
    Next I

Open in new window

0
 
drhamel69Author Commented:
I mean step through it with VBA and set the interior color.  Like this

        ActiveCell.Font.ColorIndex = strColor
        With Selection.Interior
            .Pattern = strPattern
            .PatternColorIndex = xlAutomatic
            .ColorIndex = strColor
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
0
 
NorieData ProcessorCommented:
Yeah, I figured out what you meant.

The code I posted works using the data you posted.

You could use arrays to speed up the processing if there's a lot of data, you could also just use the formula I posted and convert it for VBA.
0
 
drhamel69Author Commented:
Sorry it needs to be more robust than this.  I mean it looks good but the lists may be longer, and there will be more than 2 lists.

I need something modular enough that I could put in up to 100 names with many different groups (it will vary every time) and figure the results.
0
 
Saqib Husain, SyedEngineerCommented:
Here is my code

Sub dupgt100()
Dim cel As Range, i As Integer
    For Each cel In Range("A:A")
        If cel <> "" Then
            For i = 2 To 5
                If WorksheetFunction.SumIf(Range("A:A"), cel, Range("A:A").Offset(0, i)) > 100 Then cel.Offset(0, i).Interior.Color = RGB(255, 255, 0)
            Next i
        End If
    Next cel
End Sub
0
 
Saqib Husain, SyedEngineerCommented:
Minor improvement

Sub dupgt100()
Dim cel As Range, i As Integer
    For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        For i = 2 To 5
            If WorksheetFunction.SumIf(Range("A:A"), cel, Range("A:A").Offset(0, i)) > 100 Then cel.Offset(0, i).Interior.Color = RGB(255, 255, 0)
        Next i
    Next cel
End Sub

Open in new window

0
 
NorieData ProcessorCommented:
Perhaps you can explain further, especially why you have the separate lists and what to do with them?
0
 
drhamel69Author Commented:
Sorry.  Assume I have a long list of names that can have repeating names.  I need to go through columns C to F.  I need to change the interior color if any name is listed 2 or more times AND the sum of that column for that person is greater than 100.

Also assume that there will be blank lines which I would like to ignore.
0
 
Tommy KinardCommented:
What is the max number of name there will be? I have it at 2 right now but am still working on it.
0
 
NorieData ProcessorCommented:
If you only have one list of names then you can use SUMIF in VBA as ssaqibh has.
0
 
drhamel69Author Commented:
Could be up to 20 names listed more than once.
0
 
Saqib Husain, SyedEngineerCommented:
Have you applied the code?

What happens?
0
 
NorieData ProcessorCommented:
If you use SUMIF the no of names there are and the no of times they are repeated shouldn't make a difference.
0
 
Tommy KinardCommented:
Ok this is what I have. I take a sheet and look in col A for names, I exclude the blanks. I combine like names, after I get though adding names I compare the cell values and this is where I am stuck, you are saying that they should be colored which I have done but what about all 20 names? do I add the first and and color all of them ? so in other words how do I compare all 20 like names and see if that goes over 100?

I color the cells Yellow.

I am posting what I have:

Sub FindPairs()
    Dim PrLoc() As Long, cnt As Long, mN As Long, mK As Long
    Dim mI As Long, SeeIfThere As String, Id As Long, HowMany As Long
    ' the plan is to find matching pairs of names
    cnt = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    ReDim PrLoc(4, cnt) As Long
    For mI = 1 To cnt
        If Cells(mI, 1) > "" Then
            If InStr(1, SeeIfThere, Cells(mI, 1)) Then
                Id = InStr(1, SeeIfThere, Cells(mI, 1))
                For mN = 1 To Id
                    If Mid(SeeIfThere, mN, 1) = "|" Then HowMany = HowMany + 1
                Next
                mN = 1
                While PrLoc(mN, HowMany) <> 0
                    mN = mN + 1
                Wend
                PrLoc(mN, HowMany) = mI
                HowMany = 0
            Else
                mK = mK + 1
                PrLoc(0, mK) = mI
                SeeIfThere = SeeIfThere & "|" & Cells(mI, 1)
            End If
        End If
    Next
    GetTotals PrLoc
End Sub
Sub GetTotals(Prs() As Long)
    Dim mI As Long, Col As Long
    For mI = 1 To UBound(Prs, 2)
        If Prs(1, mI) <> 0 Then
            For Col = 3 To 6
                If Cells(Prs(0, mI), Col) + Cells(Prs(1, mI), Col) > 100 Then
                    Colors (Cells(Prs(0, mI), Col))
                    Colors (Cells(Prs(1, mI), Col))
                End If
            Next
        End If
    Next
End Sub
Sub Colors(CellId As Range)
    With CellId.Interior
        .ColorIndex = 27
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With

End Sub
0
 
drhamel69Author Commented:
This worked perfectly.  Thanks a ton.
0
 
Tommy KinardCommented:
OK this is what I did I compared all of the like names.

Sub FindPairs()
    Dim PrLoc() As Long, cnt As Long, mN As Long, mK As Long
    Dim mI As Long, SeeIfThere As String, Id As Long, HowMany As Long
    ' the plan is to find matching pairs of names
    cnt = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    ReDim PrLoc(21, cnt) As Long
    For mI = 1 To cnt
        If Cells(mI, 1) > "" Then
            If InStr(1, SeeIfThere, Cells(mI, 1)) Then
                Id = InStr(1, SeeIfThere, Cells(mI, 1))
                For mN = 1 To Id
                    If Mid(SeeIfThere, mN, 1) = "|" Then HowMany = HowMany + 1
                Next
                mN = 1
                While PrLoc(mN, HowMany) <> 0
                    mN = mN + 1
                Wend
                PrLoc(mN, HowMany) = mI
                HowMany = 0
            Else
                mK = mK + 1
                PrLoc(0, mK) = mI
                SeeIfThere = SeeIfThere & "|" & Cells(mI, 1)
            End If
        End If
    Next
    GetTotals PrLoc
End Sub
Sub GetTotals(Prs() As Long)
    Dim mI As Long, Col As Long, mN As Integer
    Dim MySum As Long
    For mI = 1 To UBound(Prs, 2)
        If Prs(1, mI) <> 0 Then
            For Col = 3 To 6
                For mN = 0 To 20
                    If Prs(mN, mI) <> 0 Then
                        MySum = MySum + Cells(Prs(mN, mI), Col)
                    Else
                        Exit For
                    End If
                Next
                If MySum > 100 Then
                    For mN = 0 To 20
                        If Prs(mN, mI) <> 0 Then
                            Colors (Cells(Prs(mN, mI), Col))
                        End If
                    Next
                End If
                MySum = 0
            Next
        End If
    Next
End Sub
Sub Colors(CellId As Range)
    With CellId.Interior
        .ColorIndex = 27
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With

End Sub
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 7
  • 6
  • 3
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now