[Last Call] Learn about multicloud storage options and how to improve your company's cloud strategy. Register Now

x
?
Solved

How to run through array and format cells with VBA

Posted on 2012-04-04
19
Medium Priority
?
358 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 7
  • 6
  • 3
  • +1
19 Comments
 
LVL 35

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 35

Expert Comment

by:Norie
ID: 37805920
Oops, my bad.

What do you mean by setting the format statically?
0
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!

 
LVL 35

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 35

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 2000 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 35

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 35

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 35

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

Industry Leaders: 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!

Question has a verified solution.

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

Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

650 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