I have a list with background colors in "A" column and value in their ceil is the name of colors.
I want to do that when I select a cell with a background color this will change the value of "C1" value to the value that have in "A" column.
(this is not the my real name of the colors, I have a specific name for each colors.)
Like vlookup but with background colors and in the same ceil.
For example:
Thank you!
Put this in the code section of the worksheet :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If dictColours.Exists(.Interior.ColorIndex) Then
Sheets("Sheet1").Range("C1").Value = dictColours(.Interior.ColorIndex)
End If
End With
End Sub
And add this to a new module, replacing the sheet reference:
Public dictColours As Scripting.Dictionary
Sub test()
Set dictColours = New Scripting.Dictionary
Dim rngTarget As Range
Set rngTarget = Sheets("Sheet1").Range("A1")
Do While rngTarget.Value <> ""
dictColours.Add rngTarget.Interior.ColorIndex, rngTarget.Value
Set rngTarget = rngTarget.Offset(1, 0)
Loop
End Sub
Think of using the conditional formatting.
elaborating on the very fine solution form Will I'd propose the following alternative code to be entirely put in the code section of the relevant worksheet
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim dictColours As Scripting.Dictionary
Set dictColours = GetDictColours(Target.Parent)
With Target
If dictColours.Exists(.Interior.ColorIndex) Then
.Parent.Range("C1").Value = dictColours(.Interior.ColorIndex)
End If
End With
End Sub
Function GetDictColours(sht As Worksheet) As Scripting.Dictionary
Dim i As Long
Set GetDictColours = New Scripting.Dictionary
Do While sht.Range("A1").Offset(i) <> ""
GetDictColours.Add sht.Range("A1").Offset(i).Interior.ColorIndex, sht.Range("A1").Offset(i).Value
i = i + 1
Loop
End Function
aside from some stylistic choices (everyone has his own favorites), it should be more simple for the OP to handle, he being (as he himself stated) a total VBA beginner!
Related
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("M1:N1").Columns(1).Value = "ΕΜΒΑΣΜΑ" Then
Columns("U").EntireColumn.Hidden = False
Columns("V").EntireColumn.Hidden = False
Else
Columns("U").EntireColumn.Hidden = True
Columns("V").EntireColumn.Hidden = True
End If
End Sub
So I have been having trouble with this code here. What I want to do is hide U, V columns if there is a value in M column called "ΕΜΒΑΣΜΑ".
Every time I let it run, it automatically hides the columns even if I have the value already in my column. Other than that, it doesn't seem to work in real time so even if I change anything, nothing happens.
Any ideas?
(a) If you want to check a whole column, you need to specify the whole column, e.g. with Range("M:M").
(b) You can't compare a Range that contains more than one cell with a value. If Range("M:M").Columns(1).Value = "ΕΜΒΑΣΜΑ" Then will throw a Type mismatch error (13). That is because a Range containing more that cell will be converted into a 2-dimensional array and you can't compare an array with a single value.
One way to check if a column contains a specific value is with the CountIf-function:
If WorksheetFunction.CountIf(Range("M:M"), "ΕΜΒΑΣΜΑ") > 0 Then
To shorten your code, you could use
Dim hideColumns As Boolean
hideColumns = (WorksheetFunction.CountIf(Range("M:M"), "ΕΜΒΑΣΜΑ") = 0)
Columns("U:V").EntireColumn.Hidden = hideColumns
Update
If you want to use that code in other events than a worksheet event, you should specify on which worksheet you want to work. Put the following routine in a regular module:
Sub showHideColumns(ws as Worksheet)
Dim hideColumns As Boolean
hideColumns = (WorksheetFunction.CountIf(ws.Range("M:M"), "ΕΜΒΑΣΜΑ") = 0)
ws.Columns("U:V").EntireColumn.Hidden = hideColumns
End Sub
Now all you have to do is to call that routine whenever you want and pass the worksheet as parameter. This could be the Workbook.Open - Event, or the click event of a button or shape. Eg put the following code in the Workbook module:
Private Sub Workbook_Open()
showHideColumns ThisWorkbook.Sheets(1)
End Sub
on a fast hand I would go like this...
maybe someone can do it shorter...
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim sht As Worksheet: Set sht = ActiveSheet
Dim c As Range
With sht.Range("M1:M" & sht.Cells(sht.Rows.Count, "M").End(xlUp).Row)
Set c = .Find("XXX", LookIn:=xlValues)
If Not c Is Nothing Then
Columns("U:V").EntireColumn.Hidden = True
Else
Columns("U:V").EntireColumn.Hidden = False
End If
End With
End Sub
I'm going crazy trying to find a way for code to run when I click on ANY of the checkboxes on my sheet. I've seen multiple articles talking about making a class module, but I can't seem to get it to work.
I have code that will populate column B to match column C. Whatever I manually type into C10 will populate into B10, even if C10 is a formula: =D9. So, I can type TRUE into D10 and the formula in C10 will result in: TRUE and then the code populates B10 to say: TRUE. Awesome... the trick is to have a checkbox linked to D10. When I click the checkbox, D10 says TRUE and the formula in C10 says TRUE, but that is as far as it goes. The VBA code does not recognize the checkbox click. If I then click on the sheet (selection change), then the code will run, so I know I need a different event.
It is easy enough to change the event to "Checkbox1_Click()", but I want it to work for ANY checkbox I click. I'm not having ANY luck after days of searching and trying different things.
here is the code I'm running so far
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
For i = 3 To 11
Range("B" & i).Value = Range("c" & i)
Next i
End Sub
Any help would be appreciated.
this works
' this goes into sheet code
Private Sub Worksheet_Activate()
activateCheckBoxes
End Sub
.
' put all this code in class a module and name the class module "ChkClass"
Option Explicit
Public WithEvents ChkBoxGroup As MSForms.CheckBox
Private Sub ChkBoxGroup_Change()
Debug.Print "ChkBoxGroup_Change"
End Sub
Private Sub ChkBoxGroup_Click()
Debug.Print "ChkBoxGroup_Click"; vbTab;
Debug.Print ChkBoxGroup.Caption; vbTab; ChkBoxGroup.Value
ChkBoxGroup.TopLeftCell.Offset(0, 2) = ChkBoxGroup.Value
End Sub
.
' this code goes into a module
Option Explicit
Dim CheckBoxes() As New ChkClass
Const numChkBoxes = 20
'
Sub doCheckBoxes()
makeCheckBoxes
activateCheckBoxes
End Sub
Sub makeCheckBoxes() ' creates a column of checkBoxes
Dim sht As Worksheet
Set sht = ActiveSheet
Dim i As Integer
For i = 1 To sht.Shapes.Count
' Debug.Print sht.Shapes(1).Properties
sht.Shapes(1).Delete
DoEvents
Next i
Dim xSize As Integer: xSize = 2 ' horizontal size (number of cells)
Dim ySize As Integer: ySize = 1 ' vertical size
Dim t As Range
Set t = sht.Range("b2").Resize(ySize, xSize)
For i = 1 To numChkBoxes
sht.Shapes.AddOLEObject ClassType:="Forms.CheckBox.1", Left:=t.Left, Top:=t.Top, Width:=t.Width - 2, Height:=t.Height
DoEvents
Set t = t.Offset(ySize)
Next i
End Sub
Sub activateCheckBoxes() ' assigns all checkBoxes on worksheet to ChkClass.ChkBoxGroup
Dim sht As Worksheet
Set sht = ActiveSheet
ReDim CheckBoxes(1 To 1)
Dim i As Integer
For i = 1 To sht.Shapes.Count
ReDim Preserve CheckBoxes(1 To i)
Set CheckBoxes(i).ChkBoxGroup = sht.Shapes(i).OLEFormat.Object.Object
Next i
End Sub
All you need is to let EVERY checkbox's _Click() event know that you want to run the Worksheet_SelectionChange event. To do so you need to add the following line into every _Click() sub:
Call Worksheet_SelectionChange(Range("a1"))
Please note that it is irrelevant what range is passed to the SelectionChange sub since you do not use the Target in your code.
I am trying to write a VBA code such that a Message box pops up whenever the value inside certain cells change.
The cells that I want to monitor change because they are linked to a query which is refreshed automatically. The VBA codes I found online only work when the cell value is changed manually, this will not work because the formula in the cells do not change, only the displayed value changes.
Can anyone help me with this?
Application Calculate (Public Variables)
The following is written for a non-contiguous range.
A message box pop's up each time a value in the range changes via formula.
Copy the codes into the appropriate modules.
Adjust the values in the constants section.
This is an automated solution. To start you should either save, close, and reopen the workbook or run the popupMsgBoxInit procedure.
Standard Module e.g. Module1
Option Explicit
Public Const popupWsName As String = "Sheet1"
Public Const popupRgAddress As String = "A1,C3,E5"
Public popupRg As Range
Public popupCount As Long
Public popupArr As Variant
Sub popupMsgBoxInit()
Set popupRg = ThisWorkbook.Worksheets(popupWsName).Range(popupRgAddress)
popupRg.Interior.Color = 65535 'xlNone
popupCount = popupRg.Cells.Count
ReDim popupArr(1 To popupCount)
Dim cel As Range
Dim i As Long
For Each cel In popupRg.Cells
i = i + 1
popupArr(i) = cel.Value
Next cel
End Sub
Sub popupMsgBox()
Dim chCount As Long
Dim cel As Range
Dim i As Long
For Each cel In popupRg.Cells
i = i + 1
If cel.Value <> popupArr(i) Then
chCount = chCount + 1
popupArr(i) = cel.Value
End If
Next cel
MsgBox "Number of Changes: " & chCount, vbInformation, "Success"
End Sub
ThisWorkbook Module
Option Explicit
Private Sub Workbook_Open()
popupMsgBoxInit
End Sub
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
popupMsgBox
End Sub
I need some idea to make this function update in real time. This function count the color of the cells for a work I need.
Function COUNTCOLOR(celdaOrigen As Range, rango As Range)
Application.Volatile
Dim celda As Range
For Each celda In rango
If celda.Interior.Color = celdaOrigen.Interior.Color Then
COUNTCOLOR = COUNTCOLOR + 1
End If
Next celda
End Function
I already try to run this function
Application.CalculateFullRebuild
But It didn't work in real time, I had to assign that function to a button and when I want to update the cells which count the colors I press the button, but that's not what I want. I want the cells count the colors in real time, I want they show me the number immediately I change a color. The cell that count the color has the following formula:
=COUNTCOLOR(A1;A1:A9998)
Where "A1" is a cell of the color I want the cell counts (like a sample), and the "A1:A9998" is the range where I want the formula find the color a the previous assigned sample. The cell will show a number of the cells in the range with the color of the sample.
I hop this information I provided can help you to give me a good answer :)
Thank you so much!
Perhaps, it's not the most elegant solution, but it works. The idea is to run the Sub every 5-10 seconds to make it work in real time.
Here is the code:
Sub COUNTCOLOR()
Dim RunTime
Dim COUNTCOLOR As Integer
Dim celda As Range
Dim lastRow As Variant
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim rango As Range
Set rango = Range("A1:A" & lastRow)
For Each celda In rango
'Compare cell interior color with cell A1
If celda.Interior.Color = Cells(1, "A").Interior.Color Then
COUNTCOLOR = COUNTCOLOR + 1
End If
Cells(1, "C").Value = COUNTCOLOR
Next celda
'To run sub every 5 seconds
RunTime = Now + TimeValue("00:00:05")
Application.OnTime RunTime, "COUNTCOLOR"
End Sub
Insert a class module and name it ClsMonitorOnupdate
Put in the code below
Option Explicit
Private WithEvents objCommandBars As Office.CommandBars
Private rMonitor As Range
Public Property Set Range(ByRef r As Range): Set rMonitor = r: End Property
Public Property Get Range() As Range: Set Range = rMonitor: End Property
Private Sub Class_Initialize()
Set objCommandBars = Application.CommandBars
End Sub
Private Sub Class_Terminate()
Set objCommandBars = Nothing
End Sub
Private Sub objCommandBars_OnUpdate()
If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Sub
If TypeName(Selection) <> "Range" Then Exit Sub
If Intersect(Selection, rMonitor) Is Nothing Then Exit Sub
rMonitor.Dirty 'dosomething to trigger your function
End Sub
In the ThisWorkbooksection you put:
Option Explicit
Private Const sRanges As String = "A1:A100" 'adjust to your range Rango?
Private Const sSheet As String = "YourSheetName" 'adjust to your sheetname
Private cMonitor As ClsMonitorOnupdate
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set cMonitor = Nothing
End Sub
Private Sub Workbook_Open()
Set cMonitor = New ClsMonitorOnupdate
Set cMonitor.Range = Sheets(sSheet).Range(sRanges)
End Sub
Adjust your Sheetname and range to monitor, after running the WorkBookopen event your range(s) will be monitored and a color-change will recalculate your Countcolor function (you can leave application.volatile out of it)
I need to assign a unique name to a cell which calls a particular user defined function.
I tried
Dim r As Range
set r = Application.Caller
r.Name = "Unique"
The following code sets cell A1 to have the name 'MyUniqueName':
Private Sub NameCell()
Dim rng As Range
Set rng = Range("A1")
rng.Name = "MyUniqueName"
End Sub
Does that help?
EDIT
I am not sure how to achieve what you need in a simple way, elegant way. I did manage this hack - see if this helps but you'd most likely want to augment my solution.
Suppose I have the following user defined function in VBA that I reference in a worksheet:
Public Function MyCustomCalc(Input1 As Integer, Input2 As Integer, Input3 As Integer) As Integer
MyCustomCalc = (Input1 + Input2) - Input3
End Function
Each time I call this function I want the cell that called that function to be assigned a name. To achieve this, if you go to 'ThisWorkbook' in your VBA project and select the 'SheetChange' event then you can add the following:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Left$(Target.Formula, 13) = "=MyCustomCalc" Then
Target.Name = "MyUniqueName"
End If
End Sub
In short, this code checks to see if the calling range is using the user defined function and then assigns the range a name (MyUniqueName) in this instance.
As I say, the above isn't great but it may give you a start. I couldn't find a way to embed code into the user defined function and set the range name directly e.g. using Application.Caller.Address or Application.Caller.Cells(1,1) etc. I am certain there is a way but I'm afraid I am a shade rusty on VBA...
I used this sub to work its way across the top row of a worksheet and if there is a value in the top row it sets that value as the name of that cell. It is VBA based so somewhat crude and simple, but it does the job!!
Private Sub SortForContactsOutlookImport()
Dim ThisCell As Object
Dim NextCell As Object
Dim RangeName As String
Set ThisCell = ActiveCell
Set NextCell = ThisCell.Offset(0, 1)
Do
If ThisCell.Value <> "" Then
RangeName = ThisCell.Value
ActiveWorkbook.Names.Add Name:=RangeName, RefersTo:=ThisCell
Set ThisCell = NextCell
Set NextCell = ThisCell.Offset(0, 1)
End If
Loop Until ThisCell.Value = "Web Page"
End Sub
I use this sub, without formal error handling:
Sub NameAdd()
Dim rng As Range
Dim nameString, rangeString, sheetString As String
On Error Resume Next
rangeString = "A5:B8"
nameString = "My_Name"
sheetString = "Sheet1"
Set rng = Worksheets(sheetString).Range(rangeString)
ThisWorkbook.Names.Add name:=nameString, RefersTo:=rng
End Sub
To Delete a Name:
Sub NameDelete()
Dim nm As name
For Each nm In ActiveWorkbook.Names
If nm.name = "My_Name" Then nm.Delete
Next
End Sub