I have an Excel Spreadsheet like this
id | data for id
| more data for id
id | data for id
id | data for id
| more data for id
| even more data for id
id | data for id
| more data for id
id | data for id
id | data for id
| more data for id
Now I want to group the data of one id by alternating the background color of the rows
var color = white
for each row
if the first cell is not empty and color is white
set color to green
if the first cell is not empty and color is green
set color to white
set background of row to color
Can anyone help me with a macro or some VBA code
Thanks
I use this formula to get the input for a conditional formatting:
=IF(B2=B1,E1,1-E1)) [content of cell E2]
Where column B contains the item that needs to be grouped and E is an auxiliary column. Every time that the upper cell (B1 on this case) is the same as the current one (B2), the upper row content from column E is returned. Otherwise, it will return 1 minus that content (that is, the outupt will be 0 or 1, depending on the value of the upper cell).
I think this does what you are looking for. Flips color when the cell in column A changes value. Runs until there is no value in column B.
Public Sub HighLightRows()
Dim i As Integer
i = 1
Dim c As Integer
c = 3 'red
Do While (Cells(i, 2) <> "")
If (Cells(i, 1) <> "") Then 'check for new ID
If c = 3 Then
c = 4 'green
Else
c = 3 'red
End If
End If
Rows(Trim(Str(i)) + ":" + Trim(Str(i))).Interior.ColorIndex = c
i = i + 1
Loop
End Sub
Based on Jason Z's answer, which from my tests seems to be wrong (at least on Excel 2010), here's a bit of code that happens to work for me :
Public Sub HighLightRows()
Dim i As Integer
i = 2 'start at 2, cause there's nothing to compare the first row with
Dim c As Integer
c = 2 'Color 1. Check http://dmcritchie.mvps.org/excel/colors.htm for color indexes
Do While (Cells(i, 1) <> "")
If (Cells(i, 1) <> Cells(i - 1, 1)) Then 'check for different value in cell A (index=1)
If c = 2 Then
c = 34 'color 2
Else
c = 2 'color 1
End If
End If
Rows(Trim(Str(i)) + ":" + Trim(Str(i))).Interior.ColorIndex = c
i = i + 1
Loop
End Sub
Do you have to use code?
if the table is static, then why not use the auto formatting capability?
It may also help if you "merge cells" of the same data. so maybe if you merge the cells of the "data, more data, even more data" into one cell, you can more easily deal with classic "each row is a row" case.
I'm barrowing this and tried to modify it for my use. I have order numbers in column a and some orders take multiple rows. Just want to alternate the white and gray per order number. What I have here alternates each row.
ChangeBackgroundColor()
' ChangeBackgroundColor Macro
'
' Keyboard Shortcut: Ctrl+Shift+B
Dim a As Integer
a = 1
Dim c As Integer
c = 15 'gray
Do While (Cells(a, 2) <> "")
If (Cells(a, 1) <> "") Then 'check for new ID
If c = 15 Then
c = 2 'white
Else
c = 15 'gray
End If
End If
Rows(Trim(Str(a)) + ":" + Trim(Str(a))).Interior.ColorIndex = c
a = a + 1
Loop
End Sub
If you select the Conditional Formatting menu option under the Format menu item, you will be given a dialog that lets you construct some logic to apply to that cell.
Your logic might not be the same as your code above, it might look more like:
Cell Value is | equal to | | and | White .... Then choose the color.
You can select the add button and make the condition as large as you need.
I have reworked Bartdude's answer, for Light Grey / White based upon a configurable column, using RGB values. A boolean var is flipped when the value changes and this is used to index the colours array via the integer values of True and False. Works for me on 2010. Call the sub with the sheet number.
Public Sub HighLightRows(intSheet As Integer)
Dim intRow As Integer: intRow = 2 ' start at 2, cause there's nothing to compare the first row with
Dim intCol As Integer: intCol = 1 ' define the column with changing values
Dim Colr1 As Boolean: Colr1 = True ' Will flip True/False; adding 2 gives 1 or 2
Dim lngColors(2 + True To 2 + False) As Long ' Indexes : 1 and 2
' True = -1, array index 1. False = 0, array index 2.
lngColors(2 + False) = RGB(235, 235, 235) ' lngColors(2) = light grey
lngColors(2 + True) = RGB(255, 255, 255) ' lngColors(1) = white
Do While (Sheets(intSheet).Cells(intRow, 1) <> "")
'check for different value in intCol, flip the boolean if it's different
If (Sheets(intSheet).Cells(intRow, intCol) <> Sheets(intSheet).Cells(intRow - 1, intCol)) Then Colr1 = Not Colr1
Sheets(intSheet).Rows(intRow).Interior.Color = lngColors(2 + Colr1) ' one colour or the other
' Optional : retain borders (these no longer show through when interior colour is changed) by specifically setting them
With Sheets(intSheet).Rows(intRow).Borders
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(220, 220, 220)
End With
intRow = intRow + 1
Loop
End Sub
Optional bonus : for SQL data, colour any NULL values with the same yellow as used in SSMS
Public Sub HighLightNULLs(intSheet As Integer)
Dim intRow As Integer: intRow = 2 ' start at 2 to avoid the headings
Dim intCol As Integer
Dim lngColor As Long: lngColor = RGB(255, 255, 225) ' pale yellow
For intRow = intRow To Sheets(intSheet).UsedRange.Rows.Count
For intCol = 1 To Sheets(intSheet).UsedRange.Columns.Count
If Sheets(intSheet).Cells(intRow, intCol) = "NULL" Then Sheets(intSheet).Cells(intRow, intCol).Interior.Color = lngColor
Next intCol
Next intRow
End Sub
I use this rule in Excel to format alternating rows:
Highlight the rows you wish to apply an alternating style to.
Press "Conditional Formatting" -> New Rule
Select "Use a formula to determine which cells to format" (last entry)
Enter rule in format value: =MOD(ROW(),2)=0
Press "Format", make required formatting for alternating rows, eg. Fill -> Color.
Press OK, Press OK.
If you wish to format alternating columns instead, use =MOD(COLUMN(),2)=0
Voila!
Related
I'm trying to solve a problem in VBA and after a long time of browsing the web for solutions, I really hope someone is able to help me.
It's actually not a very hard task, but with very little programming and VBA knowledge as a new learner, I hope I can find a useful tip or solution with the help of the community.
So my problem is as follows:
I have a table with 3 columns, the first is filled with a number to use as an ID. Column 2 and 3 have different values that needs to be compared:
What I'd like to do is select the range of column rows of column 2 and 3 based on the same ID. Once I have selected the relevant ranges of the columns, I want to compare if one name of column 2 matches one name of column 3.
So there is no need to have all names of the desired column ranges to match. One name match is enough. If a name matches, it should automatically fill in a new column "result" with 1 for match (0 for no match).
Do you have an idea, how I can select specific cells of a column based on an identifier?
Dim ID_counter As Long
ID_counter = 1
If Cell.Value = ID_counter IN Range("Column1")
Then Range("Column2").Select
AND Range("Column3").Select
WHERE ID_counter is the same
In Column4 (If one Cell.Value IN Range("Column2-X:Column2-Y")
IS IDENTICAL TO Range("Column3-X:Column3-Y"), return 1, else return 0
End Sub
Many thanks in advance for your help!
This works for your example so perhaps you can generalise it. The formula in D2 is
=IF(A2=A1,"",MAX(IF($A$2:$A$10=A2,COUNTIF($B$2:$B$10,$C$2:$C$10))))
and is an array formula so must be confirmed with CTRL, SHIFT and ENTER.
Array alternative via Match() function
This approach compares the string items of columns B and C by passing two arrays (named b,c) as arguments (c.f. section [1]):
chk = Application.Match(b, c, 0)
The resulting chk array reflects all findings of the first array's items via (1-based) position indices of corresponding items in the second array.
Non-findings return an Error 2042 value (c.f. section [2]b)); assumption is made that data are grouped by id.
Sub OneFindingPerId()
'[0]get data
Dim data: data = Sheet1.Range("A1:D10") ' << project's sheet Code(Name)
Dim b: b = Application.Index(data, 0, 2) ' 2nd column (B)
Dim c: c = Application.Index(data, 0, 3) ' 3rd column (C)
'[1]get position indices of identic strings via Match() function
Dim chk: chk = Application.Match(b, c, 0) ' found row nums of a items in b
'[2]loop found position indices (i.e. no error 2042)
Dim i As Long
For i = 2 To UBound(chk) ' omit header row
'a) define start index of new id and initialize result with 0
If data(i, 1) <> data(i - 1, 1) Then
Dim newId As Long: newId = i
data(newId, 4) = 0
End If
'b) check if found row index corresponds to same id
If Not IsError(chk(i, 1)) Then ' omit error 2042 values
If data(chk(i, 1), 1) = data(i, 1) Then ' same ids?
If data(newId, 4) = 0 Then data(newId, 4) = 1 ' ~> result One if first occurrence
End If
End If
Next i
'[3]write results
Sheet1.Range("A1").Resize(UBound(data), UBound(data, 2)) = data
End Sub
First enter this user defined function in a standard module:
Public Function zool(r1, r2, r3) As Integer
Dim i As Long, v1 As Long, v2 As String
Dim top As Long, bottom As Long
zool = 0
v1 = r1.Value
top = r1.Row
' determine limits to check
For i = top To 9999
If v1 <> r1.Offset(i - top, 0).Value Then
Exit For
End If
Next i
bottom = i - 1
For i = top To bottom
v2 = Cells(i, "B").Value
If v2 <> "" Then
For j = top To bottom
If v2 = Cells(j, "C").Value Then zool = 1
Next j
End If
Next i
End Function
Then in D2 enter:
=IF(OR(A2="",A2=A1),"",zool(A2,B2,C2))
and copy downwards:
(this assumes that the data has been sorted or organized by ID first)
I am trying to conditionally color a bunch of cells on Tab1. I am using data from a column on Tab2 and also a column on Tab3, in an attempt to match to that given cell variables.
Basic logic is:
If there is a match to the cell in column B of Tab2, then check the value in column E of that same row on Tab2.
If that value in column E is greater than zero in Tab2, then colorize the initial cell value in the search range on Tab1 on color... but if I also exist on Tab3 too, then color something else.
Copy and paste of portions of the code. This is a blown out ‘non-working’ version of the code. It takes forever to run, if it does run.
For Each cellValue In mainRng2
‘if I do not exist in SerializedInvtLocations, but do exist in NonSerializedInventory then check the value in cell E is greater than zero.
If VBA.IsError(Application.match(cellValue, Sheets("SerializedInvtLocations").Range("A2:A" & lngLastRowSer), 0)) And Not VBA.IsError(Application.match(cellValue, Sheets("NonSerializedInventory").Range("B2:B" & lngLastRowNon), 0)) Then
For Each cell In Sheets("NonSerializedInventory").Range("B2:B" & lngLastRowNon)
x = x + 1
checker = Application.WorksheetFunction.VLookup(cellValue, Range("B" & x), 1, False)
'if the vlookup value in B2
If (checker = cellValue) Then
'i exist in non-serialized list, do I have a quant > 0?
quant = Application.WorksheetFunction.VLookup(cellValue, Range("E" & x), 1, False)
If quant >= 1 Then
cellValue.Interior.ColorIndex = 8 'teal
‘Sheets("Serialized and Non-Serialized").Range(cell.Address).Interior.Color = RGB(0, 255, 0)
‘ Debug.Print "Checker value is: " & checker & " and " & cell.Address & "/" & cell.Value
i3 = i3 + 1 ‘ counter
Else
cellValue.Interior.ColorIndex = 15 'gray
End If
End If
Next cell
End If
Next cellValue
Currently, the file just hangs and does not produce results (or it taking over 40 minutes to run and I just quit out). If I modify the code and change things up - I CAN get results, but they are not accurate.
EDIT:
Another attempt:
If inSer = cellValue.Value And inNon = cellValue.Value Then
If inNonQuan >= 1 Then
cellValue.Interior.ColorIndex = 46
Else
cellValue.Interior.ColorIndex = 4
End If
End If
If inSer <> cellValue.Value And inNon = cellValue.Value Then
If inNonQuan >= 1 Then
cellValue.Interior.ColorIndex = 8
Else
cellValue.Interior.ColorIndex = 15
End If
End If
If inSer = cellValue.Value And inNon <> cellValue.Value Then
cellValue.Interior.ColorIndex = 4
End If
If inSer <> cellValue.Value And inNon <> cellValue.Value Then
cellValue.Interior.ColorIndex = 15
End If
You should be able to do something with this:
Sub Tester()
Dim c As Range, mainRng2 As Range, t2q As Variant, t3m As Boolean, Tab2, Tab3, wb
Set wb = ActiveWorkbook 'or ThisWorkbook ?
Set Tab2 = wb.Worksheets("Tab2")
Set Tab3 = wb.Worksheets("Tab3")
Set mainRng2 = wb.Worksheets("Tab1").Range("A2:A1000") 'for example
For Each c In mainRng2
'quantity on Tab2 from colE, based on ColB match
' will be an error value if no match found
t2q = Application.VLookup(c.Value, Tab2.Range("B:E"), 4, False)
'any match on Tab3 ColA ?
t3m = Not IsError(Application.Match(c.Value, Tab3.Range("A:A"), 0))
'did we get a quantity from Tab2 (was there any match)?
If Not IsError(t2q) Then
If t2q >= 1 Then
'15 if also a match on tab3, else 8
c.Interior.ColorIndex = IIf(t3m, 15, 8)
End If
End If
Next c
End Sub
My solution was disappointingly simple - VLookup only returns the first instance of a matching value, and not all subsequent values. Instead of vlookup, I should have basically 'summed' the values of a column to get anything greater than zero.
I have two different spreadsheets A and B where both of them have a column consisting of server names. Some of the server names are in common and for this I want to make a conditional query in Excel where I first want to check if server names are equal and if so check if a column in A consisting of integer values have a limit of 90. If the server has a corresponding integer value greater than 90 I want to give a color fill in one of the B's column. So roughly a python like pseudo-code would look like:
for i in range(Spreadsheet A: Column 1):
for j in range(Spreadsheet B: Column 1):
if i==j:
if i.column 2 > 90:
color fill j.column2 red
else:
color fill j.column2 green
I just used a couple of hours to learn the VBA syntax, so the answer would look like:
Sub Patch()
Dim s1 As Worksheet
Set s1 = Sheets("Patch")
Dim s2 As Worksheet
Set s2 = Sheets("Report")
For i = 5 To 259
For j = 2 To 227
If s1.Cells(i, 1) = s2.Cells(j, 1) Then
If s1.Cells(i, 7) > 90 Then
s2.Cells(j, 1).Interior.Color = vbRed
Else
s2.Cells(j, 1).Interior.Color = vbGreen
End If
Else
End If
Next j
Next i
End Sub
I am a novice of Vba.
I have been litteraly fighting all day with this bit of code:
Sub ComandsCompactVisualization()
Dim x, i As Integer
Dim CellToAnalyse As Range
x = 2
i = 0
For i = 0 To 5 Step 1
Set CellToAnalyse = Worksheets("Comandi").Cells(x + i, 2)
If Not CellToAnalyse.Font.ColorIndex = 2 Then
Worksheets("Comandi").Rows("x+i:2").Hidden = True
End If
Next i
End Sub
I am trying to hide all the rows that in cell (x+i,2) have not got red text.
I am almost there but... Rows does not seem to accept as content Rows("x+i:2").
I obtain Runtime error 13 "Type mismatch".
If I substitute its content with Rows("2:2") row 2 is deleted but I am not any more able to hide all the other rows that do not have red text in column 2.
Ideas?
Anything between quotes "like this" is just a string. To perform arithmetic on x you need to do this first, then concatenate it to the other part of the string. Like this:
.Rows((x + i) & ":2")
BTW Isn't red 3..?
Sub ComandsCompactVisualization()
Dim x as long, i As Long 'You must declare ALL variables (x was as variant in your code)
Dim CellToAnalyse As Range
dim WS as Worksheet
'x = 2 'if x is always the same value, no need to calculate it each loop
'i = 0 'numbers are initialized to be 0, strings to be "", boolean to be false.
set WS=Sheets("Commandi")
For i = 0 To 5 ' Step 1
Set CellToAnalyse = WS.Cells(2 + i, 2)
If CellToAnalyse.Font.ColorIndex <> 2 Then
CellToAnalyse.entirerow.hidden=true
' WS.Rows(2+i).entirerow.hidden = true is the same result
End If
Next i
End Sub
It's been 6 years since I've worked with Excel and i'm a little bit rusty. Here's my scenario:
I am exporting a list of issues to Excel. I need to be able differentiate the associated Link numbers in a cell (mulitple values) from each other. Example, i have two columns,
Key = the number for a ticket
Linked Issues = The Keys associated
I need a statement that would scan the Key column and find a match in the Linked Issues column. Then once the match is found the matching text will assume the font color of the Key.
Where this get complicated is each cell of the Linked Issues column could look something like this iss-3913, iss-3923, iss-1649. So essentially the scan would be for a match within the string. Any help is appreciated.
I am sorry, I don't have time to finish this right now, but wWould something like this help with maybe a loop for each cell in the first column?
Edit: Finished now, second edit to update to B5 and Z5, edit 3 fixed goof with column reference and updated to use variables to assign what column to look in.
Sub colortext()
start_row = 5
key_col = 2
linked_col = 26
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
o = start_row 'start with row one for second column
Do While Not IsEmpty(Cells(o, linked_col)) 'Do until empty cell
If Not InStr(1, Cells(o, linked_col), Cells(i, key_col)) = 0 Then 'if cell contents found in cell
With Cells(o, linked_col).Characters(Start:=InStr(1, Cells(o, linked_col), Cells(i, key_col)), Length:=Len(Cells(i, key_col))).Font
.Color = Cells(i, key_col).Font.Color 'change color of this part of the cell
End With
End If
o = o + 1 'increment the cell in second column
Loop
i = i + 1 'increment the cell in the first column
Loop
End Sub
or maybe
Something like this?
Excel VBA: change font color for specific char in a cell range
This is an old post but I thought I would provide my work around to the conditional formating issue I was having.
Sub colorkey()
start_row = 5
key_col = 2
flag_col = 4
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
Tval = Cells(i, flag_col).Value
Select Case Tval
Case "Requirement"
'cval = green
cVal = 10
Case "New Feature"
'cval = orange
cVal = 46
Case "Test"
'cval = lt blue
cVal = 28
Case "Epic"
'cval = maroon
cVal = 30
Case "Story"
'cval = dk blue
cVal = 49
Case "Theme"
'cval = grey
cVal = 48
Case "Bug"
'cval = red
cVal = 3
Case "NOT MAPPED"
'cval = Maroon
cVal = 1
End Select
Cells(i, key_col).Font.ColorIndex = cVal
i = i + 1 'increment the cell in the first column
Loop
End Sub
Sub colorlinked()
start_row = 5
key_col = 2
linked_col = 26
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
o = start_row 'start with row one for second column
Do While Not IsEmpty(Cells(o, linked_col)) 'Do until empty cell
If Not InStr(1, Cells(o, linked_col), Cells(i, key_col)) = 0 Then 'if cell contents found in cell
With Cells(o, linked_col).Characters(Start:=InStr(1, Cells(o, linked_col), Cells(i, key_col)), Length:=Len(Cells(i, key_col))).Font
.Color = Cells(i, key_col).Font.Color 'change color of this part of the cell
End With
End If
o = o + 1 'increment the cell in second column
Loop
i = i + 1 'increment the cell in the first column
Loop
MsgBox "Finished Scanning"
End Sub