So I have a column with data that need to be simplified.
ColumnA ColumnB
Cyan Blue
Navy Blue
Forest Green
I want to write a module that would ask me what to do about cyan when it first encounters it and I have to input blue. But for all the instances that cyan is encountered after this, the corresponding column B needs to be blue.
Sub SIMPLIFY()
RECORD_COUNT = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To RECORD_COUNT
If WorksheetFunction.CountIf(Columns("A"), Range("A" & i)) > 0 Then
RECORD_ROW = WorksheetFunction.Match(Range("A" & i), Columns("A"), 0)
If Cells(RECORD_ROW, 2) <> Empty Then
Cells(i, 2) = Cells(RECORD_ROW, 2)
Else
Cells(i, 2) = InputBox("Input Color for " & Cells(i, 1))
End If
End If
Next i
End Sub
Copy above code to worksheet VBA.
The code waits for any changes in column "A" and checks for previous data.
It inputs color automatically if it exists, or it asks for color when it's new.
Related
As part of a larger process I need to create a Excel VBA Macro that read the values from a column and applies basic formatting to the row based on the values in each cell.
The spreadsheet itself is exported from another program and opens directly in Excel. All columns come across formatted as General
The sequence is this:
Start at the second row in Sheet1
Look at Column J
Read the RGB value (which is shown as RGB(X,Y,Z) where X, Y, and Z are the numerical values for the color that needs to be used)
Change that rows text Color for Column A-I to that color
Continue through all rows with text
I found this thread, but I'm not able to make it work.
Any help here much appreciated.
Sub ColorIt()
Set cl = Cells(2, "J")
Do Until cl = ""
txt = cl.Value2
cl.Offset(, -9).Resize(, 9).Font.Color = _
Evaluate("SUMPRODUCT({" & Mid(txt, 5, Len(txt) - 5) & "},{1,256,65536})")
Set cl = cl.Offset(1)
Loop
End Sub
Result:
Edit2
Sub ColorIt2()
Const RGB_COL = "M"
Set cl = Cells(2, RGB_COL)
Do Until cl = ""
txt = cl.Value2
cl.Offset(, 1 - cl.Column).Resize(, cl.Column - 1).Interior.Color = _
Evaluate("SUMPRODUCT({" & Mid(txt, 5, Len(txt) - 5) & "},{1,256,65536})")
Set cl = cl.Offset(1)
Loop
End Sub
Please, use the next function. It will convert the string in a Long color (based on the RGB three parameters. It will work for both caser of comma separators ("," and ", "):
Function ExtractRGB(strRGB As String) As Long
Dim arr: arr = Split(Replace(strRGB, " ", ""), ",")
ExtractRGB = RGB(CLng(Right(arr(0), Len(arr(0)) - 4)), CLng(arr(1)), CLng(left(arr(2), Len(arr(2)) - 1)))
End Function
It can be tested in the next way:
Sub TestExtractRGB()
Dim x As String, color As Long
x = "RGB(100,10,255)"
x = "RGB(100, 10, 255)"
color = ExtractRGB(x)
Debug.Print color
Worksheet("Sheet1").Range("A2:I2").Font.color = color
'or directly:
Worksheet("Sheet1").Range("A2:I2").Font.color = _
ExtractRGB(Worksheet("Sheet1").Range("J2").value)
End Sub
If you comment x = "RGB(100, 10, 255)", it will return the same color valuem for the previous x string...
If you need to do it for all existing rows, the code must iterate from 2 to last Row and you only need to change "A2:I2" with "A" & i & ":I" & i
If necessary, I can show you how to deal with it, but I think is very simple...
I'm trying to delete every cell, and a cell to the left of it, if the value of the cell is 0. (Also, to set the interior color to no fill if the value of the cell is greater than 0.)
This is my code so far
For Each cell In Range("I2:I" & LastTransaction)
If cell.Value = 0 Then
Range(cell.Offset(0, -1).Address, cell.Address).Delete Shift:=xlUp
ElseIf cell.Value > 0 Then
cell.Interior.ColorIndex = 0
End If
Next cell
The problem here is that, every time the cells are deleted, AND SHIFTED UPWARDS, the for each loop doesn't take the upward shift into account, and skips the next cell in the range.
As per #JvdV's comment, when deleting in a loop you need to do it back to front (or in this case bottom to top), using Step -1.
In this case your For loop would look something like;
For x = LastTransaction to 2 Step -1
If Range("I" & x).Value = 0 then
Range("H" & x & ":I" & x).Delete Shift:=xlUp
ElseIf Range("I" & x).Value > 0 Then
Range("I" & x).Interior.ColorIndex = 0
End If
Next
The main issue is that, when you loop through the range, each cell refers to a particular cells on the sheet.
So your loop loops through I2, I3, I4, .... If you delete a row, all the other rows are moved up, and what was in cell Ix is now in cell I(x-1), but the loop will be at cell Ix, and so a whole row will have avoided being processed.
One solution is to store all the rows that are to be deleted in a Collection, and then delete the collection afterwards.
'data
Cells.Clear
For i = 1 To 15
Cells(i, 1) = Int(Rnd * 4)
Cells(1, i + 2) = Cells(i, 1)
Next i
'code
Dim tbd As New Collection 'to be deleted collection
For Each c In [a1:a15]
If c = 1 Then tbd.Add c 'adds a row that is to be deleted
Next c
For Each c In tbd
c.Delete 'deletes all rows in tbd
Next c
The first part of the code creates some sample data to process. Then it defines a new Collection, adds the rows to it that are to be deleted (anything with a value 1 is this case), and then deletes them from the collection.
I want to highlight numbers closer to the next whole number a darker green and numbers father away from the next whole number a darker red.
For example, 1 = dark green, 1.1 = dark red, 1.3 = lighter red, 1.5 = white, 1.7 = light green, 1.9 = dark green, and 2 = dark green
You can do this via color scaling with the setting formula.
As an example for A1:
GN: =IF(TRUNC($A$1)=$A$1,$A$1-1.1,TRUNC($A$1))
WH: =IF(TRUNC($A$1)=$A$1,$A$1-1,TRUNC($A$1)+0.5)
RD: =IF(TRUNC($A$1)=$A$1,$A$1,TRUNC($A$1)+1)
This way, it will work as you want it.
There are just two problems: references need to be absolute and you can't use it array-like (for range A1:A10 directly use $A$1:$A$10).
As the formula uses absolute references, you can not copy/paste it anywhere (it will always look for the original cell). This way you would need to enter it manually for every cell... but excel got a solution for this: VBA!
Simply select the cells you want the rules and run this code:
Sub format_me()
Dim x As Range, y As String
For Each x In Selection.Cells
y = x.Address
x.FormatConditions.AddColorScale ColorScaleType:=3
x.FormatConditions(x.FormatConditions.Count).SetFirstPriority
With x.FormatConditions(1)
With .ColorScaleCriteria(1)
.Type = 4
.Value = "=IF(TRUNC(" & y & ")=" & y & "," & y & "-1.1,TRUNC(" & y & "))"
.FormatColor.Color = 7039480
.FormatColor.TintAndShade = 0
End With
With .ColorScaleCriteria(2)
.Type = 4
.Value = "=IF(TRUNC(" & y & ")=" & y & "," & y & "-1,TRUNC(" & y & ")+0.5)"
.FormatColor.ThemeColor = 1
.FormatColor.TintAndShade = 0
End With
With .ColorScaleCriteria(3)
.Type = 4
.Value = "=IF(TRUNC(" & y & ")=" & y & "," & y & ",TRUNC(" & y & ")+1)"
.FormatColor.Color = 8109667
.FormatColor.TintAndShade = 0
End With
End With
Next
End Sub
Empty cells will have no color (still the rule is there and as soon as a number is in it, you will get the color without running the code a second time)
Alternatively, you also could create 511 different rules (for all possible shadings over 3 colors) but I am to lazy to write a code for that solution right now :P
If you have any questions, just ask :)
I'm working on a spreadsheet with conditional formatting, which turns some cells green and some red, depending on if they are in/out of the correct range.
What I need is for the red "out of spec" numbers to be copied onto the next sheet leaving the green "within spec" number off the second sheet. A bit like this:
Sheet 1:
a 2
b 4
c 5
d 6
e 3
Sheet 2:
a
b 4
c 5
d 6
e
I hope this makes sense, I did take screenshots but I can't post them! My fingers are crossed that someone can help :)
Thank you in advance
Jazz
I have assumed that data is in Column A of Sheet1.
Tested
Sub checkColornCopy()
Find the last row for automation
lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
sheet2Counter = 1
For i = 1 To lastRow
Extracting the color of the Cell interior
ConditionalColor = Worksheets("Sheet1").Cells(i, 1).Interior.ColorIndex
Color Index 3 denotes "Red"
If ConditionalColor = 3 Then
If the color is Red thenCopying the cell content of Sheet1 to Sheet2
Worksheets("Sheet2").Cells(sheet2Counter, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value
Making the cell content of Sheet1 blank
Worksheets("Sheet1").Cells(i, 1).Value = " "
sheet2Counter = sheet2Counter + 1
End If
Next
End Sub
This is probably not the best way to do it but, it worked for me.
Try:
Dim i As Integer
Dim cell As String
Sheets("Sheet1").Activate
For i = 1 To 10
'Check if font is red
If Range("A" & i).Font.Color = "fontcolor" Then
cell = Range("A" & i).Value
'Check for a number in the cell and remove the right most number
While IsNumeric(Right(cell, 1))
cell = Range("A" & i).Value
cell = Left(cell, Len(cell) - 1)
Sheets("sheet2").Range("A" & i).Value = cell
Wend
Else
'If font is not red then display cell value on sheet2
Sheets("sheet2").Range("A" & i).Value = Sheets("sheet1").Range("A" & i).Value
End If
Next
Sheets("Sheet2").Activate
Edited
In this case "A3" has red font.
To find the color of your red font use:
sub Text_Color()
Dim color As String
'"A3" has red text.
color = Sheets("sheet1").Range("A3").Font.color
MsgBox "My text color is= " & color
End Sub
Take the number found in the msgbox, in this example 393372. And replace "fontcolor" from the above code with 393372 .
So I am working on a reporting tool in Access. It queries the local tables and creates a Excel document (through VBA) and makes an Excel file.
I use the following code to color alternative code and it works beautifully
For a = 1 To rs.RecordCount
With ExcelSheet
.Cells(a + 1, 1) = a
.Cells(a + 1, 1).EntireRow.Interior.ColorIndex = IIf((a + 1) Mod 2 = 0, 2, 15)
End With
Next
Note I have to do a + 1 because a = 1 is the title row, and that is the title row.
Note: .Cells(a + 1, 1) = 1 numbers the rows (1 , 2, 3, ...)
Note : IIf((a + 1) Mod 2 = 0, 2, 15) The 2 and 15 are color codes.
Now my question is that when someone gets the Excel report they might delete a row, or do a sort operation or whatever and when they do that, it messes up the rows.
ex:
1 white row
2 grey row
3 white row
4 grey row
if i sort them I get
3 white row
1 white row
2 grey row
4 grey row
which is not what I want, I want it to keep the formatting and the numbering
Anyone to accomplish this using VBA in Access?
Tech: Office 2007
This can be accomplished with the ROW() function and some conditional formatting. The ROW() function returns the current row of the cell it is in, so it will change whenever cells are deleted, moved or sorted. Conditional formatting is re-applied whenever its conditions change, so moving or sorting rows would inform Excel to update the colors accordingly. The code would look as follows:
Dim a As Integer
Dim oneRow As Range
For a = 1 To rs.RecordCount
With ExcelSheet
''// show the row number in the first cell
.Cells(a + 1, 1).Formula = "=ROW()"
''// set formatting to alternate row colors
Set oneRow = .Cells(a + 1, 1).EntireRow
oneRow.FormatConditions.Delete
oneRow.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=MOD(ROW()-1, 2)=0"
oneRow.FormatConditions(1).Interior.ColorIndex = 2
oneRow.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=MOD(ROW()-1,2)=1"
oneRow.FormatConditions(2).Interior.ColorIndex = 15
End With
Next a
#e.James
Dim rowRange As Range
ExcelSheet.Cells(1, 1).EntireColumn.ColumnWidth = 4
ExcelSheet.Cells(1, 1) = "#"
Set rowRange = Range("2:2", rs.RecordCount & ":" & rs.RecordCount)
rowRange.Select
With ExcelApp.Selection
.FormatConditions.Delete
.FormatConditions.Add xlExpression, Formula1:="=MOD(ROW(),2)"
.FormatConditions(1).Interior.ColorIndex = 15
End With
That dosnt work. It just highlights the very top row (the title row) grey.
EDIT NEVERMIND
Its supposed to be
Set rowRange = ExcelSheet.Range("2:2", rs.RecordCount & ":" & rs.RecordCount)
EDIT NUMBER 2:
Do you know how I can insert the row numbers in each row using this method?
ANSWER:
ExcelSheet.Cells(1, 1).EntireColumn.ColumnWidth = 4
Set RowRange = Range("2:2", rs.RecordCount & ":" & rs.RecordCount)
RowRange.Columns(1).Formula = "=ROW()-1"
With RowRange
.FormatConditions.Delete
.FormatConditions.Add xlExpression, Formula1:="=MOD(ROW(),2)"
.FormatConditions(1).Interior.ColorIndex = 15
End With