Solved

How to run through array and format cells with VBA

Posted on 2012-04-04
19
345 Views
Last Modified: 2012-04-04
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
Comment
Question by:drhamel69
  • 7
  • 6
  • 3
  • +1
19 Comments
 
LVL 33

Expert Comment

by:Norie
Comment Utility
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
 
LVL 2

Author Comment

by:drhamel69
Comment Utility
If you read my post you would be aware that I CAN NOT use conditional formatting.
0
 
LVL 33

Expert Comment

by:Norie
Comment Utility
Oops, my bad.

What do you mean by setting the format statically?
0
 
LVL 33

Expert Comment

by:Norie
Comment Utility
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
 
LVL 2

Author Comment

by:drhamel69
Comment Utility
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
 
LVL 33

Expert Comment

by:Norie
Comment Utility
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
 
LVL 2

Author Comment

by:drhamel69
Comment Utility
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
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
Comment Utility
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
 
LVL 43

Accepted Solution

by:
Saqib Husain, Syed earned 500 total points
Comment Utility
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
Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

 
LVL 33

Expert Comment

by:Norie
Comment Utility
Perhaps you can explain further, especially why you have the separate lists and what to do with them?
0
 
LVL 2

Author Comment

by:drhamel69
Comment Utility
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
 
LVL 14

Expert Comment

by:Tommy Kinard
Comment Utility
What is the max number of name there will be? I have it at 2 right now but am still working on it.
0
 
LVL 33

Expert Comment

by:Norie
Comment Utility
If you only have one list of names then you can use SUMIF in VBA as ssaqibh has.
0
 
LVL 2

Author Comment

by:drhamel69
Comment Utility
Could be up to 20 names listed more than once.
0
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
Comment Utility
Have you applied the code?

What happens?
0
 
LVL 33

Expert Comment

by:Norie
Comment Utility
If you use SUMIF the no of names there are and the no of times they are repeated shouldn't make a difference.
0
 
LVL 14

Expert Comment

by:Tommy Kinard
Comment Utility
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
 
LVL 2

Author Closing Comment

by:drhamel69
Comment Utility
This worked perfectly.  Thanks a ton.
0
 
LVL 14

Expert Comment

by:Tommy Kinard
Comment Utility
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

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

728 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now