Solved

How to run through array and format cells with VBA

Posted on 2012-04-04
19
347 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
ID: 37805854
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
ID: 37805886
If you read my post you would be aware that I CAN NOT use conditional formatting.
0
 
LVL 33

Expert Comment

by:Norie
ID: 37805920
Oops, my bad.

What do you mean by setting the format statically?
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
LVL 33

Expert Comment

by:Norie
ID: 37805989
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
ID: 37805990
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
ID: 37806023
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
ID: 37806030
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
ID: 37806034
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
ID: 37806054
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
 
LVL 33

Expert Comment

by:Norie
ID: 37806055
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
ID: 37806079
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
ID: 37806100
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
ID: 37806108
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
ID: 37806122
Could be up to 20 names listed more than once.
0
 
LVL 43

Expert Comment

by:Saqib Husain, Syed
ID: 37806180
Have you applied the code?

What happens?
0
 
LVL 33

Expert Comment

by:Norie
ID: 37806188
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
ID: 37806201
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
ID: 37806283
This worked perfectly.  Thanks a ton.
0
 
LVL 14

Expert Comment

by:Tommy Kinard
ID: 37806299
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

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

831 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