Trevor3007
Well-known Member
- Joined
- Jan 26, 2017
- Messages
- 667
- Office Version
- 365
- Platform
- Windows
hi,
I use the following code
Col K (k5) which contains a drop down . Mostly its 'Part Kit' is the user choice .Can some person who has the VB knowledge add into the above VB so if a 1 is inserted in to the any cell within the range ,
d5:j200, the retrospective cell range K5:k2000, will auto insert 'Part Kit'?
Many thanks for your help.
I use the following code
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim rng As Range
For Each rng In Range("k2:k1500")
Select Case rng.Value
Case "Part Kit"
With Range("A" & rng.Row).Resize(1, 12)
.Interior.ColorIndex = 7
.Font.Bold = True
End With
Case "Full Kit"
With Range("A" & rng.Row).Resize(1, 12)
.Interior.ColorIndex = 4
.Font.Bold = True
End With
Case "No Kit"
With Range("A" & rng.Row).Resize(1, 12)
.Interior.ColorIndex = 6
.Font.Bold = True
End With
Case "Device Not Received"
With Range("A" & rng.Row).Resize(1, 12)
.Interior.ColorIndex = 28
.Font.Bold = True
End With
Case "Emailed Requested For SCCM Check"
With Range("A" & rng.Row).Resize(1, 12)
.Interior.ColorIndex = 38
.Font.Bold = True
End With
Case "Desktop UAD - On Hold ATM"
With Range("A" & rng.Row).Resize(1, 12)
.Interior.ColorIndex = 44
.Font.Bold = True
End With
Case "Device With Build Engineer"
With Range("A" & rng.Row).Resize(1, 12)
.Interior.ColorIndex = 40
.Font.Bold = False
End With
Case ""
With Range("A" & rng.Row).Resize(1, 12)
.Interior.ColorIndex = xlNone
.Font.Bold = False
End With
End Select
Next rng
Application.ScreenUpdating = True
Const BINARY_RANGE As String = "d6:J999"
Const COMMENTS_RANGE As String = "K6:K999"
Const PLACEHOLDER As String = "$@#@$"
Const MESSAGE As String = "Cell $@#@$ Only 1 Is Allowed!"
Dim Act As Boolean
Dim c As Range
Application.EnableEvents = False
For Each c In Target
Act = False
If Not Application.Intersect(c, Range(BINARY_RANGE)) Is Nothing Then
If IsError(c.Value) Then
Act = True
ElseIf c.Value = vbNullString Then
' do nothing
Else
If c.Value <> 0 And c.Value <> 1 Then
Act = True
End If
End If
If Act Then
c.Value = vbNullString
MsgBox Replace(MESSAGE, PLACEHOLDER, c.Address)
End If
End If
Next c
For Each c In Target
If Not Application.Intersect(c, Range(COMMENTS_RANGE)) Is Nothing Then
If IsError(c.Value) Then
c.Offset(0, 1).Value = vbNullString
Else
If Len(c.Value) = 0 Then
c.Offset(0, 1).Value = vbNullString
Else
c.Offset(0, 1).Value = Date
End If
End If
End If
Next c
Application.EnableEvents = True
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("jb2:jb100")) Is Nothing Then
Application.EnableEvents = False
Target = UCase(Target)
Application.EnableEvents = True
End If
On Error GoTo 0
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("b1:b1")) Is Nothing Then
Application.EnableEvents = False
Target = StrConv(Target, vbProperCase)
Application.EnableEvents = True
End If
On Error GoTo 0
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("k")) Is Nothing Then
Application.EnableEvents = False
Target = StrConv(Target, vbProperCase)
Application.EnableEvents = True
End If
On Error GoTo 0
If Target.Cells.Count > 1 Or Target.HasFormula Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("d1:d100")) Is Nothing Then
Application.EnableEvents = False
Target = LCase(Target)
Application.EnableEvents = True
End If
On Error GoTo 0
End SubCol K (k5) which contains a drop down . Mostly its 'Part Kit' is the user choice .Can some person who has the VB knowledge add into the above VB so if a 1 is inserted in to the any cell within the range ,
d5:j200, the retrospective cell range K5:k2000, will auto insert 'Part Kit'?
Many thanks for your help.
