Solved

How to run through array and format cells with VBA

Posted on 2012-04-04
19
346 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
Is Your AD Toolbox Looking More Like a Toybox?

Managing Active Directory can get complicated.  Often, the native tools for managing AD are just not up to the task.  The largest Active Directory installations in the world have relied on one tool to manage their day-to-day administration tasks: Hyena. Start your trial today.

 
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

ScreenConnect 6.0 Free Trial

Discover new time-saving features in one game-changing release, ScreenConnect 6.0, based on partner feedback. New features include a redesigned UI, app configurations and chat acknowledgement to improve customer engagement!

Question has a verified solution.

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

Enums (shorthand for ‘enumerations’) are not often used by programmers but they can be quite valuable when they are.  What are they? An Enum is just a type of variable like a string or an Integer, but in this case one that you create that contains…
Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

770 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