I am trying to make a visualized way of seeing an inventory list. There are around 200 items and I am trying to format the diagrams to show green if we have a surplus of the item, yellow if we only have one set and red if we are out of stock. This is my first project with VBA and gleaned what I could from Google results. This is what I have so far, where I have the first item (it's a shape on the diagram named "1". Cell C2 is formatted to show either "Order", "1 Set" or "In Stock" based on another cell's value for the actual number on hand.
Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Shapes("1").Fill.ForeColor.RGB = vbWhite
If ActiveSheet.Range("C2") = "1 Set" Then
ActiveSheet.Shapes("1").Fill.ForeColor.RGB = vbYellow
ActiveSheet.Shapes("1").Fill.Transparency = 0.75
End If
If ActiveSheet.Range("C2") = "In Stock" Then
ActiveSheet.Shapes("1").Fill.ForeColor.RGB = vbGreen
ActiveSheet.Shapes("1").Fill.Transparency = 0.75
End If
If ActiveSheet.Range("C2") = "Order" Then
ActiveSheet.Shapes("1").Fill.ForeColor.RGB = vbRed
ActiveSheet.Shapes("1").Fill.Transparency = 0.75
End If
And it just goes on from there. It was working perfectly for me until I got about halfway through and began getting errors for its size. So is there a way to have a main function system that can look at each of the items and apply it to the respective shape? Or, is there a way to break it into sections so each sub is smaller, but still behaves as a single process? Thank You!
Something like this should work
Private Sub Worksheet_Change(ByVal Target As Range)
Dim clr as long, c As Range
'Me is the sheet with this code
For Each c in Me.Range("C2:C100").Cells 'for example
Select Case c.Value
Case "1 Set": clr = vbYellow
Case "In Stock": clr = vbGreen
Case "Order": clr = vbRed
Case Else: clr = vbWhite
End Select
Me.Shapes(CStr(c.Row-1)).Fill.ForeColor.RGB = clr
Next c
End sub
Related
I have a function ChangeTypeByDoubleClick assigned to the button Change Type in Bulk, this ChangeTypeByDoubleClick function throws a Type Mismatch Error.
Logic of my code & how it went wrong
To explain what is Change Type in Bulk:
Change Type in Bulk button calls the ChangeTypeByDoubleClick macro function.
ChangeTypeByDoubleClick function call the Worksheet_BeforeDoubleClick function, which performs double click on every cell selected.
Worksheet_BeforeDoubleClick function changes the cell values alternatively from "B&A" to "B" to "A" to "", whenever you perform double click on the cells.
The ChangeTypeByDoubleClick function throws a Type Mismatch Error, the error occurs in the Worksheet_BeforeDoubleClick function in the line
Elself target.Row > Range (Print_Something_Rg).Row And Len (Trim(target.Offset (, 1) .Value)) > 0 Then
whenever I select continuous cells, but there is no error when I select cells separately / only select 1 cell.
Variables in my code
Print_Something_Rg is a defined range, referring to the cell to the right of Type in the picture, you can consider Print_Something_Rg as the start of different product codes.
target is the cells we selected (if you refer to the picture you can see cells being selected)
Example of selecting cells separately:
Example of selecting continuous cells:
My code
Sub ChangeTypeByDoubleClick()
Call Sheet5. Worksheet_BeforeDoubleClick (Selection, False)
End Sub
Public Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)
Dim rg_block As Range
If target.Column = Range(Print_Something_Rg).Offset(, -1).Column And Len(Trim (Range(Print_Something_Rg).Offset(1).Value)) > 0 Then
Cancel = TRUE
If target.Row = Range(Print_Something_Rg).Row Then
If Len (Trim(target.Offset(1, 1).Value)) > 0 Then
Set rg_block = Range (target.Offset (1, 1), target.Offset (1, 1) . End (xlDown)).Offset(, -1)
If target.Offset (1).Value = "" Then
rg_block.Value = "B & A"
Elself target.Offset (1).Value = "B & A" Then
rg_block.Value = "B"
Elself target.Offset(1).Value = "B" Then
rg_block.Value = "A"
Else
rg_block.Value = ""
End If
End If
Elself target.Row > Range (Print_Something_Rg).Row And Len (Trim(target.Offset (, 1) .Value)) > 0 Then
If target.Value = "" Then
target.Value =
"B & A"
Elself target.Value = "B & A" Then
target.Value = "B"
Elself target.Value = "B" Then
target.Value = "A"
Else
target.Value = ""
End If
End If
End If
End Sub
I am not exactly sure why would my code break when I select continuous cells, because the Selection should be a range already (so it shouldn't be wrong).
I have double checked the type of my code, and the type should be assigned properly. Considering it only breaks when I select continuous cells, my guess is that it has something to do with it - but I could not figure out why.
Any help would be greatly appreciated, thanks in advance.
When Target is a multi-cell range, its .Value is a 2D array, which you can't call Trim or Len on.
Normally this situation wouldn't even arise since you can only double-click a single cell, but obviously your case is different.
Add a loop to ChangeTypeByDoubleClick():
Sub ChangeTypeByDoubleClick()
If Not TypeOf Selection Is Range Then Exit Sub
Dim cell As Range
For Each cell in Selection
Sheet5.Worksheet_BeforeDoubleClick cell, False
Next
End Sub
As noted in the comments though, it would be much better to move the procedure into a standard module, and call that procedure within the Worksheet_BeforeDoubleClick handler.
For example, a speed-distance-time calculator.
Since Distance = Speed x Time,
There are 3 cells, one each for D, S, and T.
Filling any 2 of these 3 values, the other one gets calculated automatically.
Assuming you'll have your values in A1,B1 and C1
Maybe you can do a Macro that COUNT the values in the range (A1:C1), when the resulting count equals 2 (meaning at least two numbers were filled), you do a little math to calculate the remaining value. Maybe you'll need some If's to accomplish that.
You'll need to add another piece of code to trigger the macro automatically
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then 'add other cells here
Call Mymacro
End If
End Sub
First, enable the developer tab if you do not already have it.
File→Options→Customize Ribbon→check the box for Developer in the right panel
Second, go to the developer tab and click on the Visual Basic Button
Third, under the Microsoft Excel Objects folder in the left panel, double-click on Sheet1(Sheet1)
Fourth, in the box that pops up, paste the following code:
Sub Worksheet_Change(ByVal Target As Range)
Dim speed As String
Dim time As String
Dim distance As String
speed = Range("A1").Value
time = Range("B1").Value
distance = Range("C1").Value
If speed = "" And time <> "" And distance <> "" Then
Range("A1").Value = Range("C1").Value / Range("B1").Value
ElseIf speed <> "" And time = "" And distance <> "" Then
Range("B1").Value = Range("C1").Value / Range("A1").Value
ElseIf speed <> "" And time <> "" And distance = "" Then
Range("C1").Value = Range("B1").Value * Range("A1").Value
End If
End Sub
Fifth, click
File→Close and return to Microsoft Excel
Sixth, you may need to add the file location to your list of trusted locations
File→Options→Trust Center→Trust Center Settings→Trusted Locations
I am creating a function where if a cell has Yellow color and if I enter 0 in that cell, then it pops up a message box Red then colors the cell Red. And then if I enter 1 it reverts the color to Yellow.
Here's my code:
Function ColorChange(range)
If range.Interior.ColorIndex = 6 And range.Value < 1 Then
MsgBox "Project Delay!", vbCritical, "Attention required!"
range.Interior.ColorIndex = 3
Else
If range.Interior.ColorIndex = 3 And range.Value > 0 Then
range.Interior.ColorIndex = 6
End If
End If
End Function
1) It is not necessary to use a function. In VBA you can program classically (and run the macro manually) or you can program event. It means that a macro will be running in case of a particular event (like a mouse-click or a modification in the sheet). That is why Siddarth Rout spoke about Worksheet_change, it is an event. In this case, define your Sub in this way and the following code will be executed in case of Worksheet modification.
2) You have to define a Private Sub for the specific worksheet. Private Sub Worksheet_change() and you put in argument ByVal Target As range. It means that you will receive information about the range that have been changed (Target).
3) After you will use Target.Address to define the range used by your code.
4) Your 2 intricate if statements are not necessary. It is better to use an if statement and an else if statement.
5) The following code is OK for me:
Private Sub Worksheet_change(ByVal Target As range)
If range(Target.Address).Interior.ColorIndex = 6 And range(Target.Address).Value < 1 Then
MsgBox "Project Delay!", vbCritical, "Attention required!"
range(Target.Address).Interior.ColorIndex = 3
ElseIf range(Target.Address).Interior.ColorIndex = 3 And range(Target.Address).Value > 0 Then
range(Target.Address).Interior.ColorIndex = 6
End If
End Sub
I already have a barcode scanner VBA function, that recognizes the barcode number, but the problem I have is that I have to click enter every time, is there any way to do it automatically and store the count in a certain column? Currently it works if I enter the same value stored in column B, it will count the records in column C, but I want to avoid hitting enter every time
This is what I got so far
Private Sub btnAdd_Click()
Dim TargetCell As Range
If WorksheetFunction.CountIf(Sheets("Sheet1").Columns(2), TextBox1.Value) = 1 Then
Set TargetCell = Sheets("Sheet1").Columns(2).Find(TextBox1.Value, , xlValues, xlWhole).Offset(0, 1)
TargetCell.Value = TargetCell.Value + 1
Else
MsgBox "Code not found"
End If
Me.Hide
End Sub
It's hard to say what you have. For example, who presses the button? Or, does your scanner enter a return. I think the code below should work under any circumstances. Please try it.
Private Sub TextBox1_Change()
Dim TargetCell As Range
Dim Qty As Long
With TextBox1
If Len(.Value) = 3 Then
Set TargetCell = Worksheets("Sheet1").Columns(2) _
.Find(.Value, , xlValues, xlWhole)
If TargetCell Is Nothing Then
MsgBox """" & .Value & """ Code not found"
Else
With TargetCell.Offset(0, 1)
Qty = .Value + 1
.Value = Qty
End With
Application.EnableEvents = False
TextBox1.Value = "Count = " & Qty
Application.EnableEvents = True
End If
.SelStart = 0
.SelLength = Len(.Value)
End If
End With
End Sub
I think you have a user form and in this form you have a text box called TextBox1. If so, the code should be in the user form's code module. If you have a text box in your worksheet paste the code to the code module of the sheet on which the text box resides.
Now, you need to adjust this line of code If Len(.Value) = 3 Then to determine when to process the data. This is because the Change event will occur whenever even a single character is entered. I tested with 3 characters. Change the number to a value equal to the length of the numbers you scan in. In theory that still leaves the CR hanging which your scanner might also send. If that causes a problem experiment with >= in place of the = in my code.
The code will add the scan to the existing quantity, just as you had it, and indicate the new total in the text box, in case you are interested. You might replace this with "OK". The code will select the text it enters. Therefore when you enter something else, such as a new scan, it will be over-written without extra clicks being required.
I'm looking for a way for excel to alert me when a dynamic value (market feed data) is out of line by x%. The alert needs to appear in front of all my windows with a msg box "CHECK VALUES".
Is this possible to do and has anyone have an example of code for this?
More specifically
Minimum difference = 0.5
CELL A = 10
CELL B = 11
Difference = 1
ALERT user "Difference > 0.5"
Thank you in advance.
Thank you. This works perfect. Now I understand how it works, I'm hoping for another solution similar to the above. Both cells in A1 and B1 are constantly changing(variables). Cell C1 is the =ABS(B1-A1). What I need now is a code to alert me when Cell C1 is greater than 0.5.
You can use worksheet_change event. Try below code.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo err_rout
Application.EnableEvents = False
If Target.Address = "$A$1" And Target.CountLarge = 1 Then
If (Target.Value - Target.Offset(0, 1)) > 0.5 Then
MsgBox "CHECK VALUES"
End If
ElseIf Target.Address = "$B$1" And Target.CountLarge = 1 Then
If (Target.Value - Target.Offset(0, -1)) > 0.5 Then
MsgBox "CHECK VALUES"
End If
End If
err_rout:
Application.EnableEvents = True
End Sub