Output I'm hoping for is similar to this page: http://sub-atomic.com/~moses/acadcolors.html, but in Excel.
What we're trying to do is to tie AutoCAD colors to a cell. I want to be able to enter a color number in the cell (say color 10, which is red), and have the cell change to that color. I don't know how to do this without doing a macro. I assume it's going to be VBA of some type.
I have the RGB equivalents from the site above - I assume I can pull some type of a lookup.
I realize this can be done with a particularly nasty bit of conditional formatting, but I'd really prefer something a little more streamlined.
Help?
EDIT: UGP provided some really good code which did exactly what I needed. This is the final code I wound up using (adjusted for my sheet naming and with a bit of additional functionality).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range(Cells(1, 6), Cells(1000, 6))
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
CellChanged = Target.Address 'Cell that changed
If IsNumeric(Worksheets("Master").Range(CellChanged).Value) Then
If Worksheets("Master").Range(CellChanged).Value = 0 Then
Worksheets("Master").Range(CellChanged).Interior.ColorIndex = xlNone
Worksheets("Master").Range(CellChanged).Font.Color = vbBlack
Else
Worksheets("Master").Range(CellChanged).Interior.Color =
Color(Worksheets("Master").Range(CellChanged).Value)
Worksheets("Master").Range(CellChanged).Font.Color =
textColor(Worksheets("Master").Range(CellChanged).Value)
End If
End If
End If
End Sub
Function Color(ByRef ID As Integer) As Long
Dim R, G, B As Integer
For i = 3 To 257
If ID = Worksheets("Colors").Cells(i, 1).Value Then
R = Worksheets("Colors").Cells(i, 2).Value
G = Worksheets("Colors").Cells(i, 3).Value
B = Worksheets("Colors").Cells(i, 4).Value
Color = RGB(R, G, B)
Exit For
End If
Next i
End Function
Function textColor(ByRef ID As Integer) As Long
If ID <= 9 Then
textColor = vbBlack
Else
If ID Mod 10 >= 4 Then
textColor = vbWhite
Else
textColor = vbBlack
End If
End If
End Function
Put this code in Sheet1 by opening the editor with alt+f11:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range(Cells(1, 1), Cells(1000, 1000))
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
CellChanged = Target.Address 'Cell that changed
If IsNumeric(Worksheets("Sheet1").Range(CellChanged).Value) Then
Worksheets("Sheet1").Range(CellChanged).Interior.Color = Color(Worksheets("Sheet1").Range(CellChanged).Value)
End If
End If
End Sub
Function Color(ByRef ID As Integer) As Long
Dim R, G, B As Integer
For i = 2 To 256
If ID = Worksheets("Sheet2").Cells(i, 4).Value Then
R = Worksheets("Sheet2").Cells(i, 5).Value
G = Worksheets("Sheet2").Cells(i, 6).Value
B = Worksheets("Sheet2").Cells(i, 7).Value
Color = RGB(R, G, B)
Exit For
End If
Next i
End Function
It'll check for user input from Cell(1,1) to Cell(1000,1000) then it grabs the Color from Sheet2 where i put the autocad table you linked like this (copy and paste the table):
Related
I'm using Worksheet_Change to make a value (either 1 or 0) appear in the next cell (Bx) when a value is entered in a range of cells (A1:A10).
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else:
Target.Offset(0, 1).Value = 0
End If
End If
End Sub
The problem occurs when I try to clear the cells in column A.
When I select the cells I want to clear and press "Delete" I get "Run-time error '13' - Type mismatch" on the line "IF Target.Value = 1".
I would also like the cells in the B column to be cleared if I clear cells in the A column. E.g. if I delete cell A2:A5, B2:B5 should be cleared.
From what I understand the problem is that when selecting multiple cells it returns an array as the Target, and this is a mismatch with the Integer.
Is there a way around this problem?
Try this. You need to cater for multiple cells in some way, for the reasons you mention, and add an extra clause to your If.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, r1 As Range
Set r = Intersect(Target, Range("A1:A10"))
If Not r Is Nothing Then
For Each r1 In r
If r1.Value = 1 Then
r1.Offset(0, 1).Value = 1
ElseIf r1.Value = vbNullString Then
r1.Offset(0, 1).Value = vbNullString
Else
r1.Offset(0, 1).Value = 0
End If
Next r1
End If
End Sub
In a first step we add the functionality that multiple cells are selected and changed:
Private Sub Worksheet_Change_Var1(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Cells.Count > 1 Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
Next targetCell
Else
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else
Target.Offset(0, 1).Value = 0
End If
End If
End If
End Sub
In the 2nd step we understand that also the "one cell" case can be handled in the same way and we add an if clause for the "cell(s) cleared" case:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
'if cell in col A is empty, then clear cell in col B
If targetCell.Value = "" Then targetCell.Offset(0, 1).ClearContents
Next targetCell
End If
End Sub
I'd like to change Color Cell when I select it. I use this function but I can't back the original color of the Cell.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static rngcolor As Range
If Not rngcolor Is Nothing Then rngcolor.Interior.ColorIndex = xlNone
Set rngcolor = Target
rngcolor.Interior.Color = vbYellow
End Sub
You need to store the original Color as well as the cell reference. Also, the user might select more than one cell, each of which may have its own color.
Here's a starting point to deal with these complexities. Note that this accounts for the user selecting a contiguous range of >= 1 cells. They may also select a non-contiguous mutli cell range. A second more complex version provides for this
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static rngcolor As Range
Static OldColor As Variant
Dim rw As Long, cl As Long
If Not rngcolor Is Nothing Then
If IsArray(OldColor) Then
On Error GoTo NoRestore
For rw = 1 To rngcolor.Rows.Count
For cl = 1 To rngcolor.Columns.Count
If IsEmpty(OldColor(rw, cl)) Then
rngcolor.Cells(rw, cl).Interior.ColorIndex = xlNone
Else
rngcolor.Cells(rw, cl).Interior.Color = OldColor(rw, cl)
End If
Next
Next
On Error GoTo 0
Else
If IsEmpty(OldColor) Then
rngcolor.Interior.ColorIndex = xlNone
Else
rngcolor.Interior.Color = OldColor
End If
End If
End If
NoRestore:
On Error GoTo 0
Set rngcolor = Target
ReDim OldColor(1 To Target.Rows.Count, 1 To Target.Columns.Count)
For rw = 1 To Target.Rows.Count
For cl = 1 To Target.Columns.Count
If Target.Cells(rw, cl).Interior.ColorIndex = xlNone Then
OldColor(rw, cl) = Empty
Else
OldColor(rw, cl) = Target.Cells(rw, cl).Interior.Color
End If
Next
Next
rngcolor.Interior.Color = vbYellow
End Sub
Version to account for a non-contiguous range selection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static rngcolor As Range
Static OldColor As Variant
Dim OldColrRng As Variant
Dim ar As Long, rw As Long, cl As Long
If Not rngcolor Is Nothing Then
If IsArray(OldColor) Then
On Error GoTo NoRestore
For ar = 1 To rngcolor.Areas.Count
For rw = 1 To rngcolor.Areas(ar).Rows.Count
For cl = 1 To rngcolor.Areas(ar).Columns.Count
If IsEmpty(OldColor(ar)(rw, cl)) Then
rngcolor.Areas(ar).Cells(rw, cl).Interior.ColorIndex = xlNone
Else
rngcolor.Areas(ar).Cells(rw, cl).Interior.Color = OldColor(ar)(rw, cl)
End If
Next
Next
Next
On Error GoTo 0
Else
If IsEmpty(OldColor) Then
rngcolor.Interior.ColorIndex = xlNone
Else
rngcolor.Interior.Color = OldColor
End If
End If
End If
NoRestore:
On Error GoTo 0
Set rngcolor = Target
ReDim OldColor(1 To Target.Areas.Count)
For ar = 1 To Target.Areas.Count
ReDim OldColrRng(1 To Target.Areas(ar).Rows.Count, 1 To Target.Areas(ar).Columns.Count)
OldColor(ar) = OldColrRng
Next
For ar = 1 To Target.Areas.Count
For rw = 1 To Target.Areas(ar).Rows.Count
For cl = 1 To Target.Areas(ar).Columns.Count
If Target.Areas(ar).Cells(rw, cl).Interior.ColorIndex = xlNone Then
OldColor(ar)(rw, cl) = Empty
Else
OldColor(ar)(rw, cl) = Target.Areas(ar).Cells(rw, cl).Interior.Color
End If
Next
Next
Next
rngcolor.Interior.Color = vbYellow
End Sub
Note: Using Static (or global) variables is vulnerable to being stopped by an error, either in this code or other code. Depending on how important it is to restore the colors, you may want to store the Range reference and colors somewhere else: eg in cells on a (hidden) sheet, in (hidden) names, in a external repository (eg text or ini file, in the registary etc), or in an CustomXmlPart
To get this done with the original colour of the cell (as per comments) is a lot more complicated than you've done in your example (setting it back to xlnone). The following sub with accompanying function will do the trick for any RGB colour available.
Public rngcolor As Range
Public rngcolor2 As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not rngcolor Is Nothing Then
If Not rngcolor2 = "" Then
If rngcolor2 = 16777215 Then
rngcolor.Interior.ColorIndex = xlNone
Else
rngcolor.Interior.Color = rngcolor2
End If
End If
End If
Set rngcolor = Target
rngcolor2 = Color(Target)
rngcolor.Interior.Color = vbYellow
End Sub
The function getting the RGB colour form the cell: (source)
Function Color(rng As Range, Optional formatType As Integer = 0) As Variant
Dim colorVal As Variant
colorVal = Cells(rng.Row, rng.Column).Interior.Color
Select Case formatType
Case 1
Color = Hex(colorVal)
Case 2
Color = (colorVal Mod 256) & ", " & ((colorVal \ 256) Mod 256) & ", " & (colorVal \ 65536)
Case 3
Color = Cells(rng.Row, rng.Column).Interior.ColorIndex
Case Else
Color = colorVal
End Select
End Function
This stores the original cell and original colour as an RGB value in a public variable, and resets the deselected cell to these values.
Please note, if multiple cells are selected at once, their interior colour will be reset to that of the first cell in the selection.
Also note the value 16777215 is for RGB white, the default cell colour, equal to xlNone. If the exception for this is left out, the cell will be filled with white, instead of being reset to no colour. If you have cells specifically coloured white, omit this step.
I would like to select rows in my excel sheet based on a criteria and then edit the format of other cells in the same row.
I know that I can select rows using autofilters (column n equals ""):
Sub beautify()
Dim rng As Range
Set rng = ActiveSheet.Range("F60:AJ3272")
rng.AutoFilter Field:=4, Field:=4, Criteria1:=""
End Sub
Now how do I change the font of column F of the lines that I have selected to white.
You can use VBA to change the background color of a cell using .Interior.ColorIndex = RGB(r, g, b) : red and the font color of the text inside a cell with .Font.Color = RGB(r, g, b) : red
The range to change these property on should be defined, like mentionned in your question by the column and the row you selected so say you chose column F and row 12 it should look like this:
Range("F12").Font.Color = -4142
So say you want to scroll through every row of a column, and change the color of every blank cell what you could do is :
Dim i As Long
For i = 1 To Rows.Count
'Column F is 6
If Cells(i, 6).Value = "" Then
Cells(i, 1).Interior.ColorIndex = RGB(150, 0, 0)
Next i
I made slight modifications to your code and it worked:
Sub beautify()
Dim i As Long
For i = 1 To 50
If Cells(i, 9).Value = "" Then
ActiveSheet.Range(Cells(i, 10), Cells(i, 31)).Font.Color = vbBlack
ActiveSheet.Range(Cells(i, 8), Cells(i, 8)).Font.Color = vbWhite
End If
Next i
End Sub
i have the following code which would auto-fill the date in column B once i add value's in column A.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date & " " & Time = "hh:mm:ss AM/PM"
End If
Next r
Application.EnableEvents = True
End Sub
what im looking for is to also add the current time to column C.
ok so i found what im looking for but it requires little modification where the date and time are being set.
below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("D:D")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Value > 0 Then
r.Offset(0, -3).Value = Date
r.Offset(0, -3).NumberFormat = "dd-mm-yyyy"
r.Offset(0, -2).Value = Time
r.Offset(0, -2).NumberFormat = "hh:mm:ss AM/PM"
Else
r.Offset(0, -3).Value = ""
r.Offset(0, -2).Value = ""
End If
Next r
Application.EnableEvents = True
End Sub
to auto-fill column E with date, instead of column A
and auto-fill column F with time, instead of column B
and if possible im trying to have the same process but another cell on the same sheet.
While you might look at using SpecialCells to do this in one hit rather than a loop, a simple mod to your code would be:
one-shot per range area method
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error Resume Next
For Each r In Inte.Areas
r.Offset(0, 1).Cells.SpecialCells(xlCellTypeBlanks) = Date
r.Offset(0, 2).Cells.SpecialCells(xlCellTypeBlanks) = Time
Next r
Application.EnableEvents = True
End Sub
initial answer
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = vbNullString Then r.Offset(0, 1).Value = Date
If r.Offset(0, 2).Value = vbNullString Then r.Offset(0, 2).Value = Time
Next r
Application.EnableEvents = True
End Sub
if you want to:
put current Date in Target adjacent column blank cells
put current Time in Target adjacent column blank cells adjacent cells
then go like follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A"
Application.EnableEvents = False
If WorksheetFunction.CountBlank(Target.Offset(, 1)) = 0 Then Exit Sub '<--| exit if no blank cells in target adjacent column
With Target.Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference blank cells in target adjacent column
.Value = Date '<--| set referenced cells value to the current date
.Offset(, 1).Value = Time '<--| set referenced cells adjacent ones value to the current time
End With
Application.EnableEvents = True
End Sub
While if you want to:
put current Date in Target adjacent column blank cells
put current Time in Target two columns offset blank cells
then go like follows:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A:A"), Target).Address <> Target.Address Then Exit Sub '<--| exit if all target cells aren't in column "A"
Application.EnableEvents = False
On Error Resume Next
Target.Offset(, 1).SpecialCells(xlCellTypeBlanks).Value = Date '<--| set target adjacent column blank cells to the current date
Target.Offset(, 2).SpecialCells(xlCellTypeBlanks).Value = Time '<--| set target two columns offset blank cells to the current time
Application.EnableEvents = True
End Sub
where the On Error Resume Next is there to avoid two distinct If WorksheetFunction.CountBlank(someRange) Then someRange.SpecialCells(xlCellTypeBlanks).Value = someValue statements
Normally you would avoid On Error Resume Next statement and ensure you're handling any possible errors.
But in this case, being it confined to the last two statements of a sub, I think it's a good trade off in favour of code readability without actually loosing its control
I extracted the data according to ciriteria and marked them as blue. I'm looking for help with a Macro which would loop through all font colored cells (Blue) in a range.
I want to use only font colored cells in a range and mark in different color. And Msgbox show data that meet the criteria.
I had trouble finding information on looping through cells which contain only a specified colour. Anyone know how this could be done?
Dim i As Long
Dim LastRow As Integer
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Msg = "Data:"
For i = 1 To LastRow
If Cells(i + 1, 2).Value - Cells(i, 2).Value <> 0 Then
Cells(i, 2).Font.Color = vbBlue
Cells(i, 1).Font.Color = vbBlue
For Each Cell In Range("A:B")
If Cells(i, 1).Font.Color = vbBlue And Cells(i + 1, 1).Value - Cells(i, 1).Value > 4 Then
Cells(i, 2).Font.Color = vbGreen
Cells(i, 1).Font.Color = vbGreen
End If
Next
Msg = Msg & Chr(10) & i & " ) " & Cells(i, 2).Value & " : " & " --> " & Cells(i, 1).Value
End If
Next i
MsgBox Msg, vbInformation
There are multiple issues with your code:
Your loops are nested. You are searching through all the data every time you prepare one line. ==> Move the inner loop behind the loop you're coloring in.
The result message Msg = Msg & Chr(10) & i is constructed outside of the If Cells(i, 1).Font.Color = vbBlue And... condition, meaning that every line will be written into the result String. Move this part inside the 2nd loop, and the string should be contain only blue lines.
Also, please don't loop through For Each Cell In Range("A:B"). This will examine every cell in those columns, way beyond those who contain actual data. Use LastRow as in the first loop.
I believe you should be able to use the Find function to do this....
For example, select some cells on a sheet then execute:
Application.FindFormat.Interior.ColorIndex = 1
This will colour the cells black
Now execute something like:
Debug.Print ActiveCell.Parent.Cells.Find(What:="*", SearchFormat:=True).Address
This should find those cells. So you should be able to define your required Font with the FindFormat function.
BTW, make sure to test to see if the range returned is nothing for the case where it cant find any matches..
Hope that helps.
Edit:
The reason I would use the find method is because your code checks each cell in two columns. The Find method should be much quicker.
You will need to have a Do - While loop to find all cells in a range which is common with the Find function in VBA.
If you run this function, it should debug the address of any font matches that you are looking for - for a particular sheet. This should give you the idea...
Sub FindCells()
Dim rData As Range, rPtr As Range
Set rData = ActiveSheet.Range("A:B")
Application.FindFormat.Clear
Application.FindFormat.Font.Color = vbBlue
Set rPtr = rData.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
Debug.Print rPtr.Address
End If
Application.FindFormat.Clear
Application.FindFormat.Font.Color = vbGreen
Set rPtr = rData.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
Debug.Print rPtr.Address
End If
End Sub
Ok then - sorry keep getting distracted..
This code will search for cells with your fonts for a particular data range.
I believe you just need to implement your logic into the code...
Option Explicit
Public Sub Test()
Dim rData As Range
Set rData = Sheet1.Range("A:B")
Call EnumerateFontColours(rData, vbBlue)
Call EnumerateFontColours(rData, vbGreen)
End Sub
Public Sub EnumerateFontColours(ByVal DataRange As Range, ByVal FontColour As Long)
Dim rPtr As Range
Dim sStartAddress As String
Dim bCompleted As Boolean
Application.FindFormat.Clear
Application.FindFormat.Font.Color = FontColour
Set rPtr = DataRange.Find(What:="*", SearchFormat:=True)
If Not rPtr Is Nothing Then
sStartAddress = rPtr.Address
Do
'**********************
Call ProcessData(rPtr)
'**********************
Set rPtr = DataRange.Find(What:="*", After:=rPtr, SearchFormat:=True)
If Not rPtr Is Nothing Then
If rPtr.Address = sStartAddress Then bCompleted = True
Else
bCompleted = True
End If
Loop While bCompleted = False
End If
End Sub
Public Sub ProcessData(ByVal r As Range)
Debug.Print r.Address
End Sub