How can my code be made shorter?
If a user fills the cell with color yellow then if its value is 0 then it will turn to red and it will popup a message box, then if its value is > 0 it will back again to yellow, then if the user enters value of > 0 in the "no fill up cell" it will turn grey and back to no fill up if I input 0 this code is for column L only I need to make this for column M, N and O also.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ActiveSheet
On Error GoTo ExitSub
'WEEK 0
'For Task Not done
With ws.Cells(15, 12)
If Not (Application.Intersect(Range("L15"), Target) Is Nothing) Then
If .Interior.ColorIndex = 6 And .Value < 1 Then
MsgBox "Project Delay!"
Range("L15").Interior.ColorIndex = 3
Else
If Range("L15").Interior.ColorIndex = 3 And .Value > 0 Then
Range("L15").Interior.ColorIndex = 6
End If
End If
'For overlapped Task
If .Interior.ColorIndex = -4142 And .Value > 0 Then
MsgBox "Overlap!"
Range("L15").Interior.ColorIndex = 16
Else
If Range("L15").Interior.ColorIndex = 16 And .Value < 1 Then
Range("L15").Interior.ColorIndex = -4142
End If
End If
End If
End With
On Error GoTo ExitSub
'For Task Not done
With ws.Cells(17, 12)
If Not (Application.Intersect(Range("L17"), Target) Is Nothing) Then
If .Interior.ColorIndex = 6 And .Value < 1 Then
MsgBox "Project Delay!"
Range("L17").Interior.ColorIndex = 3
Else
If Range("L17").Interior.ColorIndex = 3 And .Value > 0 Then
Range("L17").Interior.ColorIndex = 6
End If
End If
'For overlapped Task
If .Interior.ColorIndex = -4142 And .Value > 0 Then
MsgBox "Overlap!"
Range("L17").Interior.ColorIndex = 16
Else
If Range("L17").Interior.ColorIndex = 16 And .Value < 1 Then
Range("L17").Interior.ColorIndex = -4142
End If
End If
End If
End With
End Sub
Please try this code. As far as I understood your intentions it should do what you want.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Tmp As Long
With Target
If .Cells.CountLarge > 1 Then Exit Sub
If (.Column >= Columns("L").Column) And (.Column <= .Columns("O").Column) Then
Tmp = Val(.Value)
Select Case .Row
Case 15
.Interior.ColorIndex = IIf(Tmp, 6, 3)
If Tmp = 0 Then
MsgBox "Project Delay!", _
vbCritical, "Attention required!"
End If
Case 17
.Interior.ColorIndex = IIf(Tmp, 16, -4142)
If Tmp Then
MsgBox "Enter a value of zero.", _
vbExclamation, "Overlap!"
End If
End Select
End If
End With
End Sub
I have kept the syntax simple so that you ought to be able to tweak it where it needs tweaking. Good luck!
Related
I'm trying to create an IF statement that does the following:
highlights (with red color) anything with a value greater than 1 and less than 26, and then continue with the rest of the macro and do other things (which I've successfully done).
if there's a value over 25, then highlight with red, produce a messagebox, and exitsub (which I've successfully done).
if ALL rows are = 1, then do nothing and exit sub (which i'm struggling with).
For Each C In Range("B2:B25000").Cells
If C.Value > 1 And C.Value < 26 Then
firstValue = C.Value
firstAddress = C.Address
Exit For
If Not (C.Value > 1 And C.Value < 26) Then Exit Sub 'No
ElseIf C.Value > 25 Then
C.Interior.Color = VBA.ColorConstants.vbRed
MsgBox "Too big!"
Exit Sub
End If
Next
C.Interior.Color = VBA.ColorConstants.vbRed 'if greater than 1 & less than 26 then Color = red
'remaining of the macro goes here
End Sub
Use the if statements to set logic flags and then decide whether to exit sub or continue.
Option Explicit
Sub test()
Dim ws As Worksheet, c As Range, lastrow As Long
Dim bAllOnes As Boolean, bTooBig As Boolean
Set ws = Sheet1
bAllOnes = True
bTooBig = False
lastrow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
For Each c In ws.Range("B2:B" & lastrow).Cells
If Val(c.Value) > 1 Then
bAllOnes = False
c.Interior.Color = VBA.ColorConstants.vbRed
If c.Value > 25 Then
bTooBig = True
End If
ElseIf Val(c.Value) < 1 Then
bAllOnes = False
End If
Next
If bTooBig Then
MsgBox "Too big!", vbCritical
Exit Sub
ElseIf bAllOnes Then
MsgBox "All 1's!", vbCritical
Exit Sub
Else
MsgBox "Continueing"
End If
End Sub
I replaced this
If Not (C.Value > 1 And C.Value < 26) Then Exit Sub
with this ElseIf Application.WorksheetFunction.max(Range("b:b")) = 1 Then Exit Sub
and it worked perfect
Having trouble with time formatting.
I have set the cell to custom format 00:00.
Currently in column A a date is inputted, this can be as 0300 which converts to 03:00 which is perfect or you can just enter 03:00.
I now have a problem if a user enters 03;00 as i need this to display 03:00
how can i ensure that all times are in the hh:mm format and not in hh;mm etc.
This needs to auto change on input for anything in column A, except what is the header (A1:A5) although this should not be affected.
Thanks
On your sheets change event you would place the following code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge = 1 And Target.Column = 1 And Target.Row > 5 Then
Target.Value2 = Replace(Target.Value2, ";", ":")
End If
End Sub
Explaining the code... it first checks to make sure that the change isn't on multiple cells (ie paste) and that the change is on column A below Row 5. If it does pass the conditional it simply replaces ; for :.
This does what i require.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim xStr As String
Dim xVal As String
Set rng1 = Range("A:A")
Set rng2 = Range("C:C")
Set rng3 = Range("I:I")
On Error GoTo EndMacro
If Application.Intersect(Target, Union(rng1, rng2, rng3)) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Target.Row < 5 Then Exit Sub
Application.EnableEvents = False
With Target
If Not .HasFormula Then
Target.Value = Replace(Target.Value, ";", ":")
Target.Value = Left(Target.Value, 5)
xVal = .Value
Select Case Len(xVal)
Case 1 ' e.g., 1 = 00:01 AM
xStr = "00:0" & xVal
Case 2 ' e.g., 12 = 00:12 AM
xStr = "00:" & xVal
Case 3 ' e.g., 735 = 07:35 AM
xStr = "0" & Left(xVal, 1) & ":" & Right(xVal, 2)
Case 4 ' e.g., 1234 = 12:34
xStr = Left(xVal, 2) & ":" & Right(xVal, 2)
Case 5 ' e.g., 12:45 = 12:45
xStr = Left(xVal, 2) & Mid(xVal, 2, 1) & Right(xVal, 2)
Case Else
Err.Raise 0
End Select
.Value = Format(TimeValue(xStr), "hh:mm")
End If
End With
Application.EnableEvents = True
Exit Sub
EndMacro:
Application.EnableEvents = True
End Sub
Thanks
I am very new with VBA in Excel. What I want to accomplish is this. When a user enters a length of say 5, then 5 columns must be outlined red. Then also when a user enters a width of say 6, then 6 rows must be outlined red. Example:
I have this code thus far:
On worksheet change:
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Address = "$A$2") Then
Call Draw2DTankl
ElseIf (Target.Address = "$B$2") Then
Call Draw2DTankw
End If
End Sub
Draw2DTankl:
Sub Draw2DTankl()
On Error Resume Next
Cells(2, 4).Value = ""
Dim x As Range
Set x = Worksheets("Sheet1").Cells
x.Borders.LineStyle = xNone
Range("A1") = "Length"
Dim Length As Integer
Length = CInt(Cells(2, 1).Value)
If (Length > 30) Then
MsgBox "A length of a maximum 30 is allowed"
Exit Sub
End If
If (Length < 0) Then
MsgBox "Invalid length value entered"
Exit Sub
End If
Dim Rws As Long, Rng As Range, r As Range
If (Length > 0) Then
Rws = 20
Set Rng = Range(Cells(20, "H"), Cells(Rws, 8 + Length - 1))
For Each r In Rng.Cells
With r.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
Next r
End If
If (Err.Number <> 0) Then
MsgBox Err.Description
End If
End Sub
Draw2DTankw:
Sub Draw2DTankw()
On Error Resume Next
Cells(2, 4).Value = ""
Dim x As Range
Set x = Worksheets("Sheet1").Cells
x.Borders.LineStyle = xNone
Range("B1") = "Width"
Dim Width As Integer
Width = CInt(Cells(2, 2).Value)
If (Width > 30) Then
MsgBox "A width of a maximum 30 is allowed"
Exit Sub
End If
If (Width < 0) Then
MsgBox "Invalid Width value entered"
Exit Sub
End If
Dim Col As Long, Rng As Range, r As Range
If (Width > 0) Then
Col = 21
Set Rng = Range(Cells(21, "H"), Cells(Col, 8 + Length - 1))
For Each r In Rng.Cells
With r.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
Next r
End If
If (Err.Number <> 0) Then
MsgBox Err.Description
End If
End Sub
Please help me. My code doesn't work. The length works, but that brakes when I change the width.
Entering my length draws:
Which is correct. But then if I enter the width of 6 this happens: (my length also dissapears)
I apologize for this long post!
It looks like in the Draw2DTankw you have Width declared above but in the rng you are using length
Dim Width As Integer Width = CInt(Cells(2, 2).Value)
Set Rng = Range(Cells(21, "H"), Cells(Col, 8 + Length - 1))
I've modified your code to draw both height and width by extending the range to include the width. This worked with I test it.
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Address = "$A$2") Or (Target.Address = "$B$2") Then
DrawTable
End If
End Sub
Sub DrawTable()
On Error Resume Next
Cells(2, 4).Value = ""
Dim x As Range
Set x = ActiveSheet.Cells
x.Borders.LineStyle = xNone
Range("A1") = "Length"
Dim Length As Integer
Length = CInt(Cells(2, 1).Value)
'Combined Width sections
Dim Width As Integer
Width = CInt(Cells(2, 2).Value)
If (Length > 30) Then
MsgBox "A length of a maximum 30 is allowed"
Exit Sub
ElseIf (Width > 30) Then
MsgBox "A width of a maximum 30 is allowed"
Exit Sub
ElseIf (Length < 0) Then
MsgBox "Invalid length value entered"
Exit Sub
ElseIf (Width < 0) Then
MsgBox "Invalid Width value entered"
Exit Sub
End If
Dim Rws As Long, Rng As Range, r As Range
If (Length > 0) Then
Rws = 20
'Added width to cells(rws)
Set Rng = Range(Cells(20, "H"), Cells(Rws + Width - 1, 8 + Length - 1))
For Each r In Rng.Cells
With r.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 3
End With
Next r
End If
If (Err.Number <> 0) Then
MsgBox Err.Description
End If
End Sub
I've written a very simple loop that goes through a table column and colors negative values red, positive values green and removes empty rows.
The problem occurs when rows are deleted. I update the value of the RowCount, and compensate i to check the same row again since a row was just deleted. If I have a column with 10 rows of which 2 are empty, they are deleted. I would expect the For i = 1 to RowCount to stop at 8, but it continues to 9 and produces an error because it then tries to delete the nonexistent 9th row.
What do I need to do so the loop stops at 8 instead of continuing (to I assume the initial value of the RowCount.
Sub ColourFilledCells()
Dim Table1 As ListObject
Set Table1 = ThisWorkbook.Worksheets(1).ListObjects(1)
Dim i As Lon, RowCount As Long
RowCount = Table1.ListRows.Count
For i = 1 To RowCount
If Not Table1.DataBodyRange(i, 1) = Empty Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = RGB(255, 0, 0)
ElseIf .Value > 0 Then
.Interior.Color = RGB(0, 255, 0)
Else
.ColorIndex = 0
End If
End With
ElseIf Table1.DataBodyRange(i, 1) = Empty Then
Table1.ListRows(i).Delete
RowCount = RowCount - 1
i = i - 1
End If
Next i
End Sub
To avoid issues with Delete affecting to For loop, count backwards.
Your code, refactored (Plus a few suggestions)
For i = RowCount to 1 Step -1
If Not isempty( Table1.DataBodyRange(i, 1)) Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = vbRed
ElseIf .Value > 0 Then
.Interior.Color = vbGreen
Else
.ColorIndex = xlColorIndexNone
End If
End With
Else
Table1.ListRows(i).Delete
End If
Next i
Try this code :
Sub ColourFilledCells()
Dim Table1 As ListObject
Dim uRng As Range
Set Table1 = ThisWorkbook.Worksheets(1).ListObjects(1)
Dim i As Long, RowCount As Long
RowCount = Table1.ListRows.Count
For i = 1 To RowCount
If Not Table1.DataBodyRange(i, 1) = Empty Then
With Table1.DataBodyRange(i, 1)
If .Value < 0 Then
.Interior.Color = RGB(255, 0, 0)
ElseIf .Value > 0 Then
.Interior.Color = RGB(0, 255, 0)
Else
.ColorIndex = 0
End If
End With
ElseIf Table1.DataBodyRange(i, 1) = Empty Then
If uRng Is Nothing Then
Set uRng = Table1.ListRows(i).Range
Else
Set uRng = Union(uRng, Table1.ListRows(i).Range)
End If
End If
Next i
If Not uRng Is Nothing Then uRng.Delete xlUp
End Sub
I have to create a cell like and I am looking a way to do it with excel formulas or VBA code.
With two differents formts red to green or just black, but not in all the case depends If.
For example:
Case 1: If cell F1 and G1 has values the format is Red to green
Case 2: If cell F1 has a value but G is empty the final format in image 1 have to be Just black
This VBA code should work. It goes into the worksheet_change event of your sheet.
I just set it for column I to change colors, but you can extend to J and K if you need to.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
If Target.Column = 6 Or Target.Column = 7 Then
Select Case Target.Column
Case Is = 6
If Target <> vbNullString And Target.Offset(, 1) <> vbNullString Then
With Target.Offset(, 2)
.Characters(Start:=1, Length:=5).Font.ColorIndex = 3
.Characters(Start:=6, Length:=3).Font.ColorIndex = 4
End With
Else: Target.Offset(, 2).Font.ColorIndex = 0
End If
Case Is = 7
If Target <> vbNullString And Target.Offset(, -1) <> vbNullString Then
With Target.Offset(, 1)
.Characters(Start:=1, Length:=5).Font.ColorIndex = 3
.Characters(Start:=6, Length:=3).Font.ColorIndex = 4
End With
Else: Target.Offset(, 1).Font.ColorIndex = 0
End If
End Select
End If
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub